{ Copyright (c) 1998-2002 by Florian Klaempfl Routines for the code generation of data structures like VMT, Messages, VTables, Interfaces descs 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 nobj; {$i fpcdefs.inc} interface uses cutils,cclasses, globtype, symdef,symsym, aasmbase,aasmtai,aasmdata ; type TVMTBuilder=class private _Class : tobjectdef; handledprotocols: tfpobjectlist; function is_new_vmt_entry(pd:tprocdef):boolean; procedure add_new_vmt_entry(pd:tprocdef); function check_msg_str(vmtpd, pd: tprocdef):boolean; function intf_search_procdef_by_name(proc: tprocdef;const name: string): tprocdef; procedure intf_get_procdefs(ImplIntf:TImplementedInterface;IntfDef:TObjectDef); procedure intf_get_procdefs_recursive(ImplIntf:TImplementedInterface;IntfDef:TObjectDef); procedure prot_get_procdefs_recursive(ImplProt:TImplementedInterface;ProtDef:TObjectDef); procedure intf_optimize_vtbls; procedure intf_allocate_vtbls; public constructor create(c:tobjectdef); destructor destroy;override; procedure generate_vmt; procedure build_interface_mappings; end; type pprocdeftree = ^tprocdeftree; tprocdeftree = record data : tprocdef; nl : tasmlabel; l,r : pprocdeftree; end; TVMTWriter=class private _Class : tobjectdef; { message tables } root : pprocdeftree; procedure disposeprocdeftree(p : pprocdeftree); procedure insertmsgint(p:TObject;arg:pointer); procedure insertmsgstr(p:TObject;arg:pointer); procedure insertint(p : pprocdeftree;var at : pprocdeftree;var count:longint); procedure insertstr(p : pprocdeftree;var at : pprocdeftree;var count:longint); procedure writenames(p : pprocdeftree); procedure writeintentry(p : pprocdeftree); procedure writestrentry(p : pprocdeftree); {$ifdef WITHDMT} { dmt } procedure insertdmtentry(p:TObject;arg:pointer); procedure writedmtindexentry(p : pprocdeftree); procedure writedmtaddressentry(p : pprocdeftree); {$endif} { published methods } procedure do_count_published_methods(p:TObject;arg:pointer); procedure do_gen_published_methods(p:TObject;arg:pointer); { virtual methods } procedure writevirtualmethods(List:TAsmList); { interface tables } function intf_get_vtbl_name(AImplIntf:TImplementedInterface): string; procedure intf_create_vtbl(rawdata: TAsmList;AImplIntf:TImplementedInterface); procedure intf_gen_intf_ref(rawdata: TAsmList;AImplIntf:TImplementedInterface); function intf_write_table:TAsmLabel; { generates the message tables for a class } function genstrmsgtab : tasmlabel; function genintmsgtab : tasmlabel; function genpublishedmethodstable : tasmlabel; function generate_field_table : tasmlabel; {$ifdef WITHDMT} { generates a DMT for _class } function gendmt : tasmlabel; {$endif WITHDMT} public constructor create(c:tobjectdef); destructor destroy;override; { write the VMT to al_globals } procedure writevmt; procedure writeinterfaceids; end; implementation uses SysUtils, globals,verbose,systems, node, symbase,symtable,symconst,symtype,defcmp, dbgbase, ncgrtti, wpobase ; {***************************************************************************** TVMTBuilder *****************************************************************************} constructor TVMTBuilder.create(c:tobjectdef); begin inherited Create; _Class:=c; end; destructor TVMTBuilder.destroy; begin end; procedure TVMTBuilder.add_new_vmt_entry(pd:tprocdef); var i : longint; vmtentry : pvmtentry; vmtpd : tprocdef; begin { new entry is needed, override was not possible } if (po_overridingmethod in pd.procoptions) then MessagePos1(pd.fileinfo,parser_e_nothing_to_be_overridden,pd.fullprocname(false)); { check that all methods have overload directive } if not(m_fpc in current_settings.modeswitches) then begin for i:=0 to _class.vmtentries.count-1 do begin vmtentry:=pvmtentry(_class.vmtentries[i]); vmtpd:=tprocdef(vmtentry^.procdef); if (vmtpd.procsym=pd.procsym) and (not(po_overload in pd.procoptions) or not(po_overload in vmtpd.procoptions)) then begin MessagePos1(pd.fileinfo,parser_e_no_overload_for_all_procs,pd.procsym.realname); { recover } include(vmtpd.procoptions,po_overload); include(pd.procoptions,po_overload); end; end; end; { Register virtual method and give it a number } if (po_virtualmethod in pd.procoptions) then begin { store vmt entry number in procdef } if (pd.extnumber<>$ffff) and (pd.extnumber<>_class.VMTEntries.Count) then internalerror(200810283); pd.extnumber:=_class.VMTEntries.Count; new(vmtentry); vmtentry^.procdef:=pd; vmtentry^.procdefderef.reset; vmtentry^.visibility:=pd.visibility; _class.VMTEntries.Add(vmtentry); end; end; function TVMTBuilder.check_msg_str(vmtpd, pd: tprocdef): boolean; begin result:=true; if not(is_objc_class_or_protocol(_class)) then begin { the only requirement for normal methods is that both either have a message string or not (the value is irrelevant) } if ((pd.procoptions * [po_msgstr]) <> (vmtpd.procoptions * [po_msgstr])) then begin MessagePos1(pd.fileinfo,parser_e_header_dont_match_forward,pd.fullprocname(false)); tprocsym(vmtpd.procsym).write_parameter_lists(pd); result:=false; end end else begin { the compiler should have ensured that the protocol or parent class method has a message name specified } if not(po_msgstr in vmtpd.procoptions) then internalerror(2009070601); if not(po_msgstr in pd.procoptions) then begin { copy the protocol's/parent class' message name to the one in the class if none has been specified there } include(pd.procoptions,po_msgstr); pd.messageinf.str:=stringdup(vmtpd.messageinf.str^); end else begin { if both have a message name, make sure they are equal } if (vmtpd.messageinf.str^<>pd.messageinf.str^) then begin MessagePos2(pd.fileinfo,parser_e_objc_message_name_changed,vmtpd.messageinf.str^,pd.messageinf.str^); result:=false; end; end; end; end; function TVMTBuilder.is_new_vmt_entry(pd:tprocdef):boolean; const po_comp = [po_classmethod,po_virtualmethod,po_staticmethod,po_interrupt,po_iocheck,po_msgint, po_exports,po_varargs,po_explicitparaloc,po_nostackframe]; var i : longint; hasequalpara, hasoverloads, pdoverload : boolean; vmtentry : pvmtentry; vmtpd : tprocdef; begin result:=false; { Load other values for easier readability } hasoverloads:=(tprocsym(pd.procsym).ProcdefList.Count>1); pdoverload:=(po_overload in pd.procoptions); { compare with all stored definitions } for i:=0 to _class.vmtentries.Count-1 do begin vmtentry:=pvmtentry(_class.vmtentries[i]); vmtpd:=tprocdef(vmtentry^.procdef); { ignore hidden entries (e.g. virtual overridden by a static) that are not visible anymore } if vmtentry^.visibility=vis_hidden then continue; { ignore different names } if vmtpd.procsym.name<>pd.procsym.name then continue; { hide private methods that are not visible anymore. For this check we must override the visibility with the highest value in the override chain. This is required for case (see tw3292) with protected-private-protected where the same vmtentry is used (PFV) } if not is_visible_for_object(vmtpd.owner,vmtentry^.visibility,_class) then continue; { inherit overload } if (po_overload in vmtpd.procoptions) then begin include(pd.procoptions,po_overload); pdoverload:=true; end; { compare parameter types only, no specifiers yet } hasequalpara:=(compare_paras(vmtpd.paras,pd.paras,cp_none,[])>=te_equal); { check that we are not trying to override a final method } if (po_finalmethod in vmtpd.procoptions) and hasequalpara and (po_overridingmethod in pd.procoptions) and is_class(_class) then MessagePos1(pd.fileinfo,parser_e_final_can_no_be_overridden,pd.fullprocname(false)) else { old definition has virtual new definition has no virtual or override } if (po_virtualmethod in vmtpd.procoptions) and ( not(po_virtualmethod in pd.procoptions) or ( { new one does not have reintroduce in case of an objccategory } (is_objccategory(_class) and not(po_reintroduce in pd.procoptions)) or { new one does not have override in case of objpas/objc class/intf/proto } (is_class_or_interface_or_objc(_class) and not is_objccategory(_class) and not(po_overridingmethod in pd.procoptions)) ) ) then begin if ( not(pdoverload or hasoverloads) or hasequalpara ) then begin if not(po_reintroduce in pd.procoptions) then if not(is_objc_class_or_protocol(_class)) then MessagePos1(pd.fileinfo,parser_w_should_use_override,pd.fullprocname(false)) else begin { In Objective-C, you cannot create a new VMT entry to start a new inheritance tree. We therefore give an error when the class is implemented in Pascal, to avoid confusion due to things working differently with Object Pascal classes. In case of external classes, we only give a hint, because requiring override everywhere may make automated header translation tools too complex. } if not(oo_is_external in _class.objectoptions) then if not is_objccategory(_class) then MessagePos1(pd.fileinfo,parser_e_must_use_override_objc,pd.fullprocname(false)) else MessagePos1(pd.fileinfo,parser_e_must_use_reintroduce_objc,pd.fullprocname(false)) { there may be a lot of these in auto-translated heaeders, so only calculate the fullprocname if the hint will be shown } else if CheckVerbosity(V_Hint) then if not is_objccategory(_class) then MessagePos1(pd.fileinfo,parser_h_should_use_override_objc,pd.fullprocname(false)) else MessagePos1(pd.fileinfo,parser_h_should_use_reintroduce_objc,pd.fullprocname(false)); { no new entry, but copy the message name if any from the procdef in the parent class } check_msg_str(vmtpd,pd); exit; end; { disable/hide old VMT entry } vmtentry^.visibility:=vis_hidden; end; end { both are virtual? } else if (po_virtualmethod in pd.procoptions) and (po_virtualmethod in vmtpd.procoptions) then begin { same parameter and return types (parameter specifiers will be checked below) } if hasequalpara and compatible_childmethod_resultdef(vmtpd.returndef,pd.returndef) then begin { inherite calling convention when it was explicit and the current definition has none explicit set } if (po_hascallingconvention in vmtpd.procoptions) and not(po_hascallingconvention in pd.procoptions) then begin pd.proccalloption:=vmtpd.proccalloption; include(pd.procoptions,po_hascallingconvention); end; { All parameter specifiers and some procedure the flags have to match except abstract and override } if (compare_paras(vmtpd.paras,pd.paras,cp_all,[])pd.proccalloption) or (vmtpd.proctypeoption<>pd.proctypeoption) or ((vmtpd.procoptions*po_comp)<>(pd.procoptions*po_comp)) then begin MessagePos1(pd.fileinfo,parser_e_header_dont_match_forward,pd.fullprocname(false)); tprocsym(vmtpd.procsym).write_parameter_lists(pd); end; check_msg_str(vmtpd,pd); { Give a note if the new visibility is lower. For a higher visibility update the vmt info } if vmtentry^.visibility>pd.visibility then MessagePos4(pd.fileinfo,parser_n_ignore_lower_visibility,pd.fullprocname(false), visibilityname[pd.visibility],tobjectdef(vmtpd.owner.defowner).objrealname^,visibilityname[vmtentry^.visibility]) else if pd.visibility>vmtentry^.visibility then vmtentry^.visibility:=pd.visibility; { override old virtual method in VMT } if (vmtpd.extnumber<>i) then internalerror(200611084); pd.extnumber:=vmtpd.extnumber; vmtentry^.procdef:=pd; exit; end { different parameters } else begin { when we got an override directive then can search futher for the procedure to override. If we are starting a new virtual tree then hide the old tree } if not(po_overridingmethod in pd.procoptions) and not(pdoverload or hasoverloads) then begin if not(po_reintroduce in pd.procoptions) then begin if not is_object(_class) and not is_objc_class_or_protocol(_class) then MessagePos1(pd.fileinfo,parser_w_should_use_override,pd.fullprocname(false)) else { objects don't allow starting a new virtual tree and neither does Objective-C } MessagePos1(pd.fileinfo,parser_e_header_dont_match_forward,vmtpd.fullprocname(false)); end; { disable/hide old VMT entry } vmtentry^.visibility:=vis_hidden; end; end; end; end; { No entry found, we need to create a new entry } result:=true; end; function TVMTBuilder.intf_search_procdef_by_name(proc: tprocdef;const name: string): tprocdef; const po_comp = [po_classmethod,po_staticmethod,po_interrupt,po_iocheck,po_msgint, po_exports,po_varargs,po_explicitparaloc,po_nostackframe]; var implprocdef : Tprocdef; i: cardinal; hclass : tobjectdef; hashedid : THashedIDString; srsym : tsym; begin result:=nil; hashedid.id:=name; hclass:=_class; while assigned(hclass) do begin srsym:=tsym(hclass.symtable.FindWithHash(hashedid)); if assigned(srsym) and (srsym.typ=procsym) then begin for i:=0 to Tprocsym(srsym).ProcdefList.Count-1 do begin implprocdef:=tprocdef(tprocsym(srsym).ProcdefList[i]); if (implprocdef.procsym=tprocsym(srsym)) and (compare_paras(proc.paras,implprocdef.paras,cp_all,[cpo_ignorehidden,cpo_comparedefaultvalue])>=te_equal) and (compare_defs(proc.returndef,implprocdef.returndef,nothingn)>=te_equal) and (proc.proccalloption=implprocdef.proccalloption) and (proc.proctypeoption=implprocdef.proctypeoption) and ((proc.procoptions*po_comp)=((implprocdef.procoptions+[po_virtualmethod])*po_comp)) and check_msg_str(proc,implprocdef) then begin result:=implprocdef; exit; end; end; end; hclass:=hclass.childof; end; end; procedure TVMTBuilder.intf_get_procdefs(ImplIntf:TImplementedInterface;IntfDef:TObjectDef); var i : longint; def : tdef; hs, prefix, mappedname: string; implprocdef: tprocdef; begin prefix:=ImplIntf.IntfDef.symtable.name^+'.'; for i:=0 to IntfDef.symtable.DefList.Count-1 do begin def:=tdef(IntfDef.symtable.DefList[i]); if assigned(def) and (def.typ=procdef) then begin { Find implementing procdef 1. Check for mapped name 2. Use symbol name } implprocdef:=nil; hs:=prefix+tprocdef(def).procsym.name; mappedname:=ImplIntf.GetMapping(hs); if mappedname<>'' then implprocdef:=intf_search_procdef_by_name(tprocdef(def),mappedname); if not assigned(implprocdef) then implprocdef:=intf_search_procdef_by_name(tprocdef(def),tprocdef(def).procsym.name); { Add procdef to the implemented interface } if assigned(implprocdef) then begin if (implprocdef._class.objecttype<>odt_objcclass) then ImplIntf.AddImplProc(implprocdef) else begin { If no message name has been specified for the method in the objcclass, copy it from the protocol definition. } if not(po_msgstr in tprocdef(def).procoptions) then begin include(tprocdef(def).procoptions,po_msgstr); implprocdef.messageinf.str:=stringdup(tprocdef(def).messageinf.str^); end else begin { If a message name has been specified in the objcclass, it has to match the message name in the protocol definition. } if (implprocdef.messageinf.str^<>tprocdef(def).messageinf.str^) then MessagePos2(implprocdef.fileinfo,parser_e_objc_message_name_changed,tprocdef(def).messageinf.str^,implprocdef.messageinf.str^); end; end; end else if (ImplIntf.IType=etStandard) and not(po_optional in tprocdef(def).procoptions) then Message1(sym_e_no_matching_implementation_found,tprocdef(def).fullprocname(false)); end; end; end; procedure TVMTBuilder.intf_get_procdefs_recursive(ImplIntf:TImplementedInterface;IntfDef:TObjectDef); begin if assigned(IntfDef.childof) then intf_get_procdefs_recursive(ImplIntf,IntfDef.childof); intf_get_procdefs(ImplIntf,IntfDef); end; procedure TVMTBuilder.prot_get_procdefs_recursive(ImplProt:TImplementedInterface;ProtDef:TObjectDef); var i: longint; begin { don't check the same protocol twice } if handledprotocols.IndexOf(ProtDef)<>-1 then exit; handledprotocols.add(ProtDef); for i:=0 to ProtDef.ImplementedInterfaces.count-1 do prot_get_procdefs_recursive(ImplProt,TImplementedInterface(ProtDef.ImplementedInterfaces[i]).intfdef); intf_get_procdefs(ImplProt,ProtDef); end; procedure TVMTBuilder.intf_optimize_vtbls; type tcompintfentry = record weight: longint; compintf: longint; end; { Max 1000 interface in the class header interfaces it's enough imho } tcompintfs = array[0..1000] of tcompintfentry; pcompintfs = ^tcompintfs; tequals = array[0..1000] of longint; pequals = ^tequals; timpls = array[0..1000] of longint; pimpls = ^timpls; var aequals: pequals; compats: pcompintfs; impls: pimpls; ImplIntfCount, w,i,j,k: longint; ImplIntfI, ImplIntfJ : TImplementedInterface; cij: boolean; cji: boolean; begin ImplIntfCount:=_class.ImplementedInterfaces.count; if ImplIntfCount>=High(tequals) then Internalerror(200006135); getmem(compats,sizeof(tcompintfentry)*ImplIntfCount); getmem(aequals,sizeof(longint)*ImplIntfCount); getmem(impls,sizeof(longint)*ImplIntfCount); filldword(compats^,(sizeof(tcompintfentry) div sizeof(dword))*ImplIntfCount,dword(-1)); filldword(aequals^,ImplIntfCount,dword(-1)); filldword(impls^,ImplIntfCount,dword(-1)); { ismergepossible is a containing relation meaning of ismergepossible(a,b,w) = if implementorfunction map of a is contained implementorfunction map of b imp(a,b) and imp(b,c) => imp(a,c) ; imp(a,b) and imp(b,a) => a == b } { the order is very important for correct allocation } for i:=0 to ImplIntfCount-1 do begin for j:=i+1 to ImplIntfCount-1 do begin ImplIntfI:=TImplementedInterface(_class.ImplementedInterfaces[i]); ImplIntfJ:=TImplementedInterface(_class.ImplementedInterfaces[j]); cij:=ImplIntfI.IsImplMergePossible(ImplIntfJ,w); cji:=ImplIntfJ.IsImplMergePossible(ImplIntfI,w); if cij and cji then { i equal j } begin { get minimum index of equal } if aequals^[j]=-1 then aequals^[j]:=i; end else if cij then begin { get minimum index of maximum weight } if compats^[i].weight3, 3->1 Second loop: 2->1 (because 3 was replaced with 1) } repeat k:=0; for i:=0 to ImplIntfCount-1 do begin if compats^[impls^[i]].compintf<>-1 then impls^[i]:=compats^[impls^[i]].compintf else if aequals^[impls^[i]]<>-1 then impls^[i]:=aequals^[impls^[i]] else inc(k); end; until k=ImplIntfCount; { Update the VtblImplIntf } for i:=0 to ImplIntfCount-1 do begin ImplIntfI:=TImplementedInterface(_class.ImplementedInterfaces[i]); ImplIntfI.VtblImplIntf:=TImplementedInterface(_class.ImplementedInterfaces[impls^[i]]); end; freemem(compats); freemem(aequals); freemem(impls); end; procedure TVMTBuilder.intf_allocate_vtbls; var i : longint; ImplIntf : TImplementedInterface; begin { Allocation vtbl space } for i:=0 to _class.ImplementedInterfaces.count-1 do begin ImplIntf:=TImplementedInterface(_class.ImplementedInterfaces[i]); { if it implements itself and if it's not implemented by delegation } if (ImplIntf.VtblImplIntf=ImplIntf) and (ImplIntf.IType=etStandard) then begin { allocate a pointer in the object memory } with tObjectSymtable(_class.symtable) do begin datasize:=align(datasize,sizeof(pint)); ImplIntf.Ioffset:=datasize; datasize:=datasize+sizeof(pint); end; end; end; { Update ioffset of current interface with the ioffset from the interface that is reused to implements this interface } for i:=0 to _class.ImplementedInterfaces.count-1 do begin ImplIntf:=TImplementedInterface(_class.ImplementedInterfaces[i]); if ImplIntf.VtblImplIntf<>ImplIntf then ImplIntf.IOffset:=ImplIntf.VtblImplIntf.IOffset; end; end; procedure TVMTBuilder.generate_vmt; var i : longint; def : tdef; old_current_objectdef : tobjectdef; begin old_current_objectdef:=current_objectdef; current_objectdef:=_class; _class.resetvmtentries; { inherit (copy) VMT from parent object } if assigned(_class.childof) then begin if not assigned(_class.childof.vmtentries) then internalerror(200810281); _class.copyvmtentries(_class.childof); end; { process all procdefs, we must process the defs to keep the same order as that is written in the source to be compatible with the indexes in the interface vtable (PFV) } for i:=0 to _class.symtable.DefList.Count-1 do begin def:=tdef(_class.symtable.DefList[i]); if def.typ=procdef then begin { VMT entry } if is_new_vmt_entry(tprocdef(def)) then add_new_vmt_entry(tprocdef(def)); end; end; build_interface_mappings; if assigned(_class.ImplementedInterfaces) and not(is_objc_class_or_protocol(_class)) then begin { Optimize interface tables to reuse wrappers } intf_optimize_vtbls; { Allocate interface tables } intf_allocate_vtbls; end; current_objectdef:=old_current_objectdef; end; procedure TVMTBuilder.build_interface_mappings; var ImplIntf : TImplementedInterface; i: longint; begin { Find Procdefs implementing the interfaces } if assigned(_class.ImplementedInterfaces) and (_class.objecttype<>odt_objcprotocol) then begin { Collect implementor functions into the tImplementedInterface.procdefs } case _class.objecttype of odt_class: begin for i:=0 to _class.ImplementedInterfaces.count-1 do begin ImplIntf:=TImplementedInterface(_class.ImplementedInterfaces[i]); intf_get_procdefs_recursive(ImplIntf,ImplIntf.IntfDef) end; end; odt_objcclass: begin { Object Pascal interfaces are afterwards optimized via the intf_optimize_vtbls() method, but we can't do this for protocols -> check for duplicates here already. } handledprotocols:=tfpobjectlist.create(false); for i:=0 to _class.ImplementedInterfaces.count-1 do begin ImplIntf:=TImplementedInterface(_class.ImplementedInterfaces[i]); prot_get_procdefs_recursive(ImplIntf,ImplIntf.IntfDef); end; handledprotocols.free; end else internalerror(2009091801); end end; end; {***************************************************************************** TVMTWriter *****************************************************************************} constructor TVMTWriter.create(c:tobjectdef); begin inherited Create; _Class:=c; end; destructor TVMTWriter.destroy; begin end; {************************************** Message Tables **************************************} procedure TVMTWriter.disposeprocdeftree(p : pprocdeftree); begin if assigned(p^.l) then disposeprocdeftree(p^.l); if assigned(p^.r) then disposeprocdeftree(p^.r); dispose(p); end; procedure TVMTWriter.insertint(p : pprocdeftree;var at : pprocdeftree;var count:longint); begin if at=nil then begin at:=p; inc(count); end else begin if p^.data.messageinf.iat^.data.messageinf.i then insertint(p,at^.r,count) else Message1(parser_e_duplicate_message_label,tostr(p^.data.messageinf.i)); end; end; procedure TVMTWriter.insertstr(p : pprocdeftree;var at : pprocdeftree;var count:longint); var i : integer; begin if at=nil then begin at:=p; inc(count); end else begin i:=CompareStr(p^.data.messageinf.str^,at^.data.messageinf.str^); if i<0 then insertstr(p,at^.l,count) else if i>0 then insertstr(p,at^.r,count) else Message1(parser_e_duplicate_message_label,p^.data.messageinf.str^); end; end; procedure TVMTWriter.insertmsgint(p:TObject;arg:pointer); var i : longint; pd : Tprocdef; pt : pprocdeftree; begin if tsym(p).typ<>procsym then exit; for i:=0 to Tprocsym(p).ProcdefList.Count-1 do begin pd:=tprocdef(Tprocsym(p).ProcdefList[i]); if po_msgint in pd.procoptions then begin new(pt); pt^.data:=pd; pt^.l:=nil; pt^.r:=nil; insertint(pt,root,plongint(arg)^); end; end; end; procedure TVMTWriter.insertmsgstr(p:TObject;arg:pointer); var i : longint; pd : Tprocdef; pt : pprocdeftree; begin if tsym(p).typ<>procsym then exit; for i:=0 to Tprocsym(p).ProcdefList.Count-1 do begin pd:=tprocdef(Tprocsym(p).ProcdefList[i]); if po_msgstr in pd.procoptions then begin new(pt); pt^.data:=pd; pt^.l:=nil; pt^.r:=nil; insertstr(pt,root,plongint(arg)^); end; end; end; procedure TVMTWriter.writenames(p : pprocdeftree); var ca : pchar; len : byte; begin current_asmdata.getdatalabel(p^.nl); if assigned(p^.l) then writenames(p^.l); current_asmdata.asmlists[al_globals].concat(cai_align.create(const_align(sizeof(pint)))); current_asmdata.asmlists[al_globals].concat(Tai_label.Create(p^.nl)); len:=length(p^.data.messageinf.str^); current_asmdata.asmlists[al_globals].concat(tai_const.create_8bit(len)); getmem(ca,len+1); move(p^.data.messageinf.str^[1],ca^,len); ca[len]:=#0; current_asmdata.asmlists[al_globals].concat(Tai_string.Create_pchar(ca,len)); if assigned(p^.r) then writenames(p^.r); end; procedure TVMTWriter.writestrentry(p : pprocdeftree); begin if assigned(p^.l) then writestrentry(p^.l); { write name label } current_asmdata.asmlists[al_globals].concat(Tai_const.Create_sym(p^.nl)); current_asmdata.asmlists[al_globals].concat(Tai_const.Createname(p^.data.mangledname,0)); if assigned(p^.r) then writestrentry(p^.r); end; function TVMTWriter.genstrmsgtab : tasmlabel; var count : aint; begin root:=nil; count:=0; { insert all message handlers into a tree, sorted by name } _class.symtable.SymList.ForEachCall(@insertmsgstr,@count); { write all names } if assigned(root) then writenames(root); { now start writing of the message string table } current_asmdata.getdatalabel(result); current_asmdata.asmlists[al_globals].concat(cai_align.create(const_align(sizeof(pint)))); current_asmdata.asmlists[al_globals].concat(Tai_label.Create(result)); current_asmdata.asmlists[al_globals].concat(Tai_const.Create_pint(count)); if assigned(root) then begin writestrentry(root); disposeprocdeftree(root); end; end; procedure TVMTWriter.writeintentry(p : pprocdeftree); begin if assigned(p^.l) then writeintentry(p^.l); { write name label } current_asmdata.asmlists[al_globals].concat(Tai_const.Create_32bit(p^.data.messageinf.i)); current_asmdata.asmlists[al_globals].concat(Tai_const.Createname(p^.data.mangledname,0)); if assigned(p^.r) then writeintentry(p^.r); end; function TVMTWriter.genintmsgtab : tasmlabel; var r : tasmlabel; count : longint; begin root:=nil; count:=0; { insert all message handlers into a tree, sorted by name } _class.symtable.SymList.ForEachCall(@insertmsgint,@count); { now start writing of the message string table } current_asmdata.getdatalabel(r); current_asmdata.asmlists[al_globals].concat(cai_align.create(const_align(sizeof(pint)))); current_asmdata.asmlists[al_globals].concat(Tai_label.Create(r)); genintmsgtab:=r; current_asmdata.asmlists[al_globals].concat(Tai_const.Create_32bit(count)); if assigned(root) then begin writeintentry(root); disposeprocdeftree(root); end; end; {$ifdef WITHDMT} {************************************** DMT **************************************} procedure TVMTWriter.insertdmtentry(p:TObject;arg:pointer); var hp : tprocdef; pt : pprocdeftree; begin if tsym(p).typ=procsym then begin hp:=tprocsym(p).definition; while assigned(hp) do begin if (po_msgint in hp.procoptions) then begin new(pt); pt^.p:=hp; pt^.l:=nil; pt^.r:=nil; insertint(pt,root); end; hp:=hp.nextoverloaded; end; end; end; procedure TVMTWriter.writedmtindexentry(p : pprocdeftree); begin if assigned(p^.l) then writedmtindexentry(p^.l); al_globals.concat(Tai_const.Create_32bit(p^.data.messageinf.i)); if assigned(p^.r) then writedmtindexentry(p^.r); end; procedure TVMTWriter.writedmtaddressentry(p : pprocdeftree); begin if assigned(p^.l) then writedmtaddressentry(p^.l); al_globals.concat(Tai_const_symbol.Createname(p^.data.mangledname,0)); if assigned(p^.r) then writedmtaddressentry(p^.r); end; function TVMTWriter.gendmt : tasmlabel; var r : tasmlabel; begin root:=nil; count:=0; gendmt:=nil; { insert all message handlers into a tree, sorted by number } _class.symtable.SymList.ForEachCall(insertdmtentry); if count>0 then begin current_asmdata.getdatalabel(r); gendmt:=r; al_globals.concat(cai_align.create(const_align(sizeof(pint)))); al_globals.concat(Tai_label.Create(r)); { entries for caching } al_globals.concat(Tai_const.Create_ptr(0)); al_globals.concat(Tai_const.Create_ptr(0)); al_globals.concat(Tai_const.Create_32bit(count)); if assigned(root) then begin writedmtindexentry(root); writedmtaddressentry(root); disposeprocdeftree(root); end; end; end; {$endif WITHDMT} {************************************** Published Methods **************************************} procedure TVMTWriter.do_count_published_methods(p:TObject;arg:pointer); var i : longint; pd : tprocdef; begin if (tsym(p).typ<>procsym) then exit; for i:=0 to Tprocsym(p).ProcdefList.Count-1 do begin pd:=tprocdef(Tprocsym(p).ProcdefList[i]); if (pd.procsym=tsym(p)) and (pd.visibility=vis_published) then inc(plongint(arg)^); end; end; procedure TVMTWriter.do_gen_published_methods(p:TObject;arg:pointer); var i : longint; l : tasmlabel; pd : tprocdef; begin if (tsym(p).typ<>procsym) then exit; for i:=0 to Tprocsym(p).ProcdefList.Count-1 do begin pd:=tprocdef(Tprocsym(p).ProcdefList[i]); if (pd.procsym=tsym(p)) and (pd.visibility=vis_published) then begin current_asmdata.getdatalabel(l); current_asmdata.asmlists[al_typedconsts].concat(cai_align.create(const_align(sizeof(pint)))); current_asmdata.asmlists[al_typedconsts].concat(Tai_label.Create(l)); current_asmdata.asmlists[al_typedconsts].concat(Tai_const.Create_8bit(length(tsym(p).realname))); current_asmdata.asmlists[al_typedconsts].concat(Tai_string.Create(tsym(p).realname)); current_asmdata.asmlists[al_globals].concat(Tai_const.Create_sym(l)); if po_abstractmethod in pd.procoptions then current_asmdata.asmlists[al_globals].concat(Tai_const.Create_sym(nil)) else current_asmdata.asmlists[al_globals].concat(Tai_const.Createname(pd.mangledname,0)); end; end; end; function TVMTWriter.genpublishedmethodstable : tasmlabel; var l : tasmlabel; count : longint; begin count:=0; _class.symtable.SymList.ForEachCall(@do_count_published_methods,@count); if count>0 then begin current_asmdata.getdatalabel(l); current_asmdata.asmlists[al_globals].concat(cai_align.create(const_align(sizeof(pint)))); current_asmdata.asmlists[al_globals].concat(Tai_label.Create(l)); current_asmdata.asmlists[al_globals].concat(Tai_const.Create_32bit(count)); _class.symtable.SymList.ForEachCall(@do_gen_published_methods,nil); genpublishedmethodstable:=l; end else genpublishedmethodstable:=nil; end; function TVMTWriter.generate_field_table : tasmlabel; var i : longint; sym : tsym; fieldtable, classtable : tasmlabel; classindex, fieldcount : longint; classtablelist : TFPList; begin classtablelist:=TFPList.Create; current_asmdata.getdatalabel(fieldtable); current_asmdata.getdatalabel(classtable); maybe_new_object_file(current_asmdata.asmlists[al_rtti]); new_section(current_asmdata.asmlists[al_rtti],sec_rodata,classtable.name,const_align(sizeof(pint))); { retrieve field info fields } fieldcount:=0; for i:=0 to _class.symtable.SymList.Count-1 do begin sym:=tsym(_class.symtable.SymList[i]); if (sym.typ=fieldvarsym) and (sym.visibility=vis_published) then begin if tfieldvarsym(sym).vardef.typ<>objectdef then internalerror(200611032); classindex:=classtablelist.IndexOf(tfieldvarsym(sym).vardef); if classindex=-1 then classtablelist.Add(tfieldvarsym(sym).vardef); inc(fieldcount); end; end; { write fields } current_asmdata.asmlists[al_rtti].concat(Tai_label.Create(fieldtable)); current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_16bit(fieldcount)); if (tf_requires_proper_alignment in target_info.flags) then current_asmdata.asmlists[al_rtti].concat(cai_align.Create(sizeof(TConstPtrUInt))); current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_sym(classtable)); for i:=0 to _class.symtable.SymList.Count-1 do begin sym:=tsym(_class.symtable.SymList[i]); if (sym.typ=fieldvarsym) and (sym.visibility=vis_published) then begin if (tf_requires_proper_alignment in target_info.flags) then current_asmdata.asmlists[al_rtti].concat(cai_align.Create(sizeof(pint))); current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_pint(tfieldvarsym(sym).fieldoffset)); classindex:=classtablelist.IndexOf(tfieldvarsym(sym).vardef); if classindex=-1 then internalerror(200611033); current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_16bit(classindex+1)); current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(length(tfieldvarsym(sym).realname))); current_asmdata.asmlists[al_rtti].concat(Tai_string.Create(tfieldvarsym(sym).realname)); end; end; { generate the class table } current_asmdata.asmlists[al_rtti].concat(cai_align.create(const_align(sizeof(pint)))); current_asmdata.asmlists[al_rtti].concat(Tai_label.Create(classtable)); current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_16bit(classtablelist.count)); if (tf_requires_proper_alignment in target_info.flags) then current_asmdata.asmlists[al_rtti].concat(cai_align.Create(sizeof(TConstPtrUInt))); for i:=0 to classtablelist.Count-1 do current_asmdata.asmlists[al_rtti].concat(Tai_const.Createname(tobjectdef(classtablelist[i]).vmt_mangledname,0)); classtablelist.free; result:=fieldtable; end; {************************************** Interface tables **************************************} function TVMTWriter.intf_get_vtbl_name(AImplIntf:TImplementedInterface): string; begin result:=make_mangledname('VTBL',_class.owner,_class.objname^+'_$_'+AImplIntf.IntfDef.objname^); end; procedure TVMTWriter.intf_create_vtbl(rawdata: TAsmList;AImplIntf:TImplementedInterface); var pd : tprocdef; vtblstr, hs : string; i : longint; begin vtblstr:=intf_get_vtbl_name(AImplIntf); section_symbol_start(rawdata,vtblstr,AT_DATA,true,sec_data,const_align(sizeof(pint))); if assigned(AImplIntf.procdefs) then begin for i:=0 to AImplIntf.procdefs.count-1 do begin pd:=tprocdef(AImplIntf.procdefs[i]); hs:=make_mangledname('WRPR',_class.owner,_class.objname^+'_$_'+AImplIntf.IntfDef.objname^+'_$_'+ tostr(i)+'_$_'+pd.mangledname); { create reference } rawdata.concat(Tai_const.Createname(hs,0)); end; end; section_symbol_end(rawdata,vtblstr); end; procedure TVMTWriter.intf_gen_intf_ref(rawdata: TAsmList;AImplIntf:TImplementedInterface); var iidlabel, guidlabel : tasmlabel; i: longint; pd: tprocdef; begin { GUID } if AImplIntf.IntfDef.objecttype in [odt_interfacecom] then begin { label for GUID } current_asmdata.getdatalabel(guidlabel); rawdata.concat(cai_align.create(const_align(sizeof(pint)))); rawdata.concat(Tai_label.Create(guidlabel)); with AImplIntf.IntfDef.iidguid^ do begin rawdata.concat(Tai_const.Create_32bit(longint(D1))); rawdata.concat(Tai_const.Create_16bit(D2)); rawdata.concat(Tai_const.Create_16bit(D3)); for i:=Low(D4) to High(D4) do rawdata.concat(Tai_const.Create_8bit(D4[i])); end; current_asmdata.asmlists[al_globals].concat(Tai_const.Create_sym(guidlabel)); end else begin { nil for Corba interfaces } current_asmdata.asmlists[al_globals].concat(Tai_const.Create_sym(nil)); end; { VTable } current_asmdata.asmlists[al_globals].concat(Tai_const.Createname(intf_get_vtbl_name(AImplIntf.VtblImplIntf),0)); { IOffset field } case AImplIntf.VtblImplIntf.IType of etFieldValue, etFieldValueClass, etStandard: current_asmdata.asmlists[al_globals].concat(Tai_const.Create_pint(AImplIntf.VtblImplIntf.IOffset)); etStaticMethodResult, etStaticMethodClass: current_asmdata.asmlists[al_globals].concat(Tai_const.Createname( tprocdef(tpropertysym(AImplIntf.ImplementsGetter).propaccesslist[palt_read].procdef).mangledname, 0 )); etVirtualMethodResult, etVirtualMethodClass: begin pd := tprocdef(tpropertysym(AImplIntf.ImplementsGetter).propaccesslist[palt_read].procdef); current_asmdata.asmlists[al_globals].concat(Tai_const.Create_pint(pd._class.vmtmethodoffset(pd.extnumber))); end; else internalerror(200802162); end; { IIDStr } current_asmdata.getdatalabel(iidlabel); rawdata.concat(cai_align.create(const_align(sizeof(pint)))); rawdata.concat(Tai_label.Create(iidlabel)); rawdata.concat(Tai_const.Create_8bit(length(AImplIntf.IntfDef.iidstr^))); if AImplIntf.IntfDef.objecttype=odt_interfacecom then rawdata.concat(Tai_string.Create(upper(AImplIntf.IntfDef.iidstr^))) else rawdata.concat(Tai_string.Create(AImplIntf.IntfDef.iidstr^)); current_asmdata.asmlists[al_globals].concat(Tai_const.Create_sym(iidlabel)); { IType } current_asmdata.asmlists[al_globals].concat(Tai_const.Create_pint(aint(AImplIntf.VtblImplIntf.IType))); end; function TVMTWriter.intf_write_table:TAsmLabel; var rawdata : TAsmList; i : longint; ImplIntf : TImplementedInterface; intftablelab : tasmlabel; begin current_asmdata.getdatalabel(intftablelab); current_asmdata.asmlists[al_globals].concat(cai_align.create(const_align(sizeof(pint)))); current_asmdata.asmlists[al_globals].concat(Tai_label.Create(intftablelab)); current_asmdata.asmlists[al_globals].concat(Tai_const.Create_pint(_class.ImplementedInterfaces.count)); rawdata:=TAsmList.Create; { Write vtbls } for i:=0 to _class.ImplementedInterfaces.count-1 do begin ImplIntf:=TImplementedInterface(_class.ImplementedInterfaces[i]); if ImplIntf.VtblImplIntf=ImplIntf then intf_create_vtbl(rawdata,ImplIntf); end; { Write vtbl references } for i:=0 to _class.ImplementedInterfaces.count-1 do begin ImplIntf:=TImplementedInterface(_class.ImplementedInterfaces[i]); intf_gen_intf_ref(rawdata,ImplIntf); end; { Write interface table } current_asmdata.asmlists[al_globals].concatlist(rawdata); rawdata.free; result:=intftablelab; end; { Write interface identifiers to the data section } procedure TVMTWriter.writeinterfaceids; var i : longint; s : string; begin if assigned(_class.iidguid) then begin s:=make_mangledname('IID',_class.owner,_class.objname^); maybe_new_object_file(current_asmdata.asmlists[al_globals]); new_section(current_asmdata.asmlists[al_globals],sec_rodata,s,const_align(sizeof(pint))); current_asmdata.asmlists[al_globals].concat(Tai_symbol.Createname_global(s,AT_DATA,0)); current_asmdata.asmlists[al_globals].concat(Tai_const.Create_32bit(longint(_class.iidguid^.D1))); current_asmdata.asmlists[al_globals].concat(Tai_const.Create_16bit(_class.iidguid^.D2)); current_asmdata.asmlists[al_globals].concat(Tai_const.Create_16bit(_class.iidguid^.D3)); for i:=Low(_class.iidguid^.D4) to High(_class.iidguid^.D4) do current_asmdata.asmlists[al_globals].concat(Tai_const.Create_8bit(_class.iidguid^.D4[i])); end; maybe_new_object_file(current_asmdata.asmlists[al_globals]); s:=make_mangledname('IIDSTR',_class.owner,_class.objname^); new_section(current_asmdata.asmlists[al_globals],sec_rodata,s,0); current_asmdata.asmlists[al_globals].concat(Tai_symbol.Createname_global(s,AT_DATA,0)); current_asmdata.asmlists[al_globals].concat(Tai_const.Create_8bit(length(_class.iidstr^))); current_asmdata.asmlists[al_globals].concat(Tai_string.Create(_class.iidstr^)); end; procedure TVMTWriter.writevirtualmethods(List:TAsmList); var vmtpd : tprocdef; vmtentry : pvmtentry; i : longint; procname : string; {$ifdef vtentry} hs : string; {$endif vtentry} begin if not assigned(_class.VMTEntries) then exit; for i:=0 to _class.VMTEntries.Count-1 do begin vmtentry:=pvmtentry(_class.vmtentries[i]); vmtpd:=vmtentry^.procdef; { safety checks } if not(po_virtualmethod in vmtpd.procoptions) then internalerror(200611082); if vmtpd.extnumber<>i then internalerror(200611083); if (po_abstractmethod in vmtpd.procoptions) then procname:='FPC_ABSTRACTERROR' else if not wpoinfomanager.optimized_name_for_vmt(_class,vmtpd,procname) then procname:=vmtpd.mangledname; List.concat(Tai_const.createname(procname,0)); {$ifdef vtentry} hs:='VTENTRY'+'_'+_class.vmt_mangledname+'$$'+tostr(_class.vmtmethodoffset(i) div sizeof(pint)); current_asmdata.asmlists[al_globals].concat(tai_symbol.CreateName(hs,AT_DATA,0)); {$endif vtentry} end; end; procedure TVMTWriter.writevmt; var methodnametable,intmessagetable, strmessagetable,classnamelabel, fieldtablelabel : tasmlabel; {$ifdef WITHDMT} dmtlabel : tasmlabel; {$endif WITHDMT} interfacetable : tasmlabel; {$ifdef vtentry} hs: string; {$endif vtentry} begin {$ifdef WITHDMT} dmtlabel:=gendmt; {$endif WITHDMT} { write tables for classes, this must be done before the actual class is written, because we need the labels defined } if is_class(_class) then begin current_asmdata.getdatalabel(classnamelabel); maybe_new_object_file(current_asmdata.asmlists[al_globals]); new_section(current_asmdata.asmlists[al_globals],sec_rodata,classnamelabel.name,const_align(sizeof(pint))); { interface table } if _class.ImplementedInterfaces.count>0 then interfacetable:=intf_write_table; methodnametable:=genpublishedmethodstable; fieldtablelabel:=generate_field_table; { write class name } current_asmdata.asmlists[al_globals].concat(Tai_label.Create(classnamelabel)); current_asmdata.asmlists[al_globals].concat(Tai_const.Create_8bit(length(_class.objrealname^))); current_asmdata.asmlists[al_globals].concat(Tai_string.Create(_class.objrealname^)); { generate message and dynamic tables } if (oo_has_msgstr in _class.objectoptions) then strmessagetable:=genstrmsgtab; if (oo_has_msgint in _class.objectoptions) then intmessagetable:=genintmsgtab; end; { write debug info } maybe_new_object_file(current_asmdata.asmlists[al_globals]); new_section(current_asmdata.asmlists[al_globals],sec_rodata,_class.vmt_mangledname,const_align(sizeof(pint))); current_asmdata.asmlists[al_globals].concat(Tai_symbol.Createname_global(_class.vmt_mangledname,AT_DATA,0)); { determine the size with symtable.datasize, because } { size gives back 4 for classes } current_asmdata.asmlists[al_globals].concat(Tai_const.Create(aitconst_ptr,tObjectSymtable(_class.symtable).datasize)); current_asmdata.asmlists[al_globals].concat(Tai_const.Create(aitconst_ptr,-int64(tObjectSymtable(_class.symtable).datasize))); {$ifdef WITHDMT} if _class.classtype=ct_object then begin if assigned(dmtlabel) then current_asmdata.asmlists[al_globals].concat(Tai_const_symbol.Create(dmtlabel))) else current_asmdata.asmlists[al_globals].concat(Tai_const.Create_ptr(0)); end; {$endif WITHDMT} { write pointer to parent VMT, this isn't implemented in TP } { but this is not used in FPC ? (PM) } { it's not used yet, but the delphi-operators as and is need it (FK) } { it is not written for parents that don't have any vmt !! } if assigned(_class.childof) and (oo_has_vmt in _class.childof.objectoptions) then current_asmdata.asmlists[al_globals].concat(Tai_const.Createname(_class.childof.vmt_mangledname,0)) else current_asmdata.asmlists[al_globals].concat(Tai_const.Create_sym(nil)); { write extended info for classes, for the order see rtl/inc/objpash.inc } if is_class(_class) then begin { pointer to class name string } current_asmdata.asmlists[al_globals].concat(Tai_const.Create_sym(classnamelabel)); { pointer to dynamic table or nil } if (oo_has_msgint in _class.objectoptions) then current_asmdata.asmlists[al_globals].concat(Tai_const.Create_sym(intmessagetable)) else current_asmdata.asmlists[al_globals].concat(Tai_const.Create_sym(nil)); { pointer to method table or nil } current_asmdata.asmlists[al_globals].concat(Tai_const.Create_sym(methodnametable)); { pointer to field table } current_asmdata.asmlists[al_globals].concat(Tai_const.Create_sym(fieldtablelabel)); { pointer to type info of published section } current_asmdata.asmlists[al_globals].concat(Tai_const.Create_sym(RTTIWriter.get_rtti_label(_class,fullrtti))); { inittable for con-/destruction } if _class.members_need_inittable then current_asmdata.asmlists[al_globals].concat(Tai_const.Create_sym(RTTIWriter.get_rtti_label(_class,initrtti))) else current_asmdata.asmlists[al_globals].concat(Tai_const.Create_sym(nil)); { auto table } current_asmdata.asmlists[al_globals].concat(Tai_const.Create_sym(nil)); { interface table } if _class.ImplementedInterfaces.count>0 then current_asmdata.asmlists[al_globals].concat(Tai_const.Create_sym(interfacetable)) else if _class.implements_any_interfaces then current_asmdata.asmlists[al_globals].concat(Tai_const.Create_sym(nil)) else current_asmdata.asmlists[al_globals].concat(Tai_const.Create_sym(current_asmdata.RefAsmSymbol('FPC_EMPTYINTF'))); { table for string messages } if (oo_has_msgstr in _class.objectoptions) then current_asmdata.asmlists[al_globals].concat(Tai_const.Create_sym(strmessagetable)) else current_asmdata.asmlists[al_globals].concat(Tai_const.Create_sym(nil)); end; { write virtual methods } writevirtualmethods(current_asmdata.asmlists[al_globals]); current_asmdata.asmlists[al_globals].concat(Tai_const.create(aitconst_ptr,0)); { write the size of the VMT } current_asmdata.asmlists[al_globals].concat(Tai_symbol_end.Createname(_class.vmt_mangledname)); {$ifdef vtentry} { write vtinherit symbol to notify the linker of the class inheritance tree } hs:='VTINHERIT'+'_'+_class.vmt_mangledname+'$$'; if assigned(_class.childof) then hs:=hs+_class.childof.vmt_mangledname else hs:=hs+_class.vmt_mangledname; current_asmdata.asmlists[al_globals].concat(tai_symbol.CreateName(hs,AT_DATA,0)); {$endif vtentry} end; end.