summaryrefslogtreecommitdiff
path: root/compiler/nobj.pas
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/nobj.pas')
-rw-r--r--compiler/nobj.pas1353
1 files changed, 1353 insertions, 0 deletions
diff --git a/compiler/nobj.pas b/compiler/nobj.pas
new file mode 100644
index 0000000000..df059347c0
--- /dev/null
+++ b/compiler/nobj.pas
@@ -0,0 +1,1353 @@
+{
+ 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
+ ;
+
+ type
+ pprocdeftree = ^tprocdeftree;
+ tprocdeftree = record
+ data : tprocdef;
+ nl : tasmlabel;
+ l,r : pprocdeftree;
+ end;
+
+ pprocdefcoll = ^tprocdefcoll;
+ tprocdefcoll = record
+ data : tprocdef;
+ hidden : boolean;
+ visible : boolean;
+ next : pprocdefcoll;
+ end;
+
+ pvmtentry = ^tvmtentry;
+ tvmtentry = record
+ speedvalue : cardinal;
+ name : pstring;
+ firstprocdef : pprocdefcoll;
+ next : pvmtentry;
+ end;
+
+ tclassheader=class
+ private
+ _Class : tobjectdef;
+ private
+ { message tables }
+ root : pprocdeftree;
+ procedure disposeprocdeftree(p : pprocdeftree);
+ procedure insertmsgint(p : tnamedindexitem;arg:pointer);
+ procedure insertmsgstr(p : tnamedindexitem;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}
+ private
+ { dmt }
+ procedure insertdmtentry(p : tnamedindexitem;arg:pointer);
+ procedure writedmtindexentry(p : pprocdeftree);
+ procedure writedmtaddressentry(p : pprocdeftree);
+{$endif}
+ private
+ { published methods }
+ procedure do_count_published_methods(p : tnamedindexitem;arg:pointer);
+ procedure do_gen_published_methods(p : tnamedindexitem;arg:pointer);
+ private
+ { vmt }
+ firstvmtentry : pvmtentry;
+ nextvirtnumber : integer;
+ has_constructor,
+ has_virtual_method : boolean;
+ procedure newdefentry(vmtentry:pvmtentry;pd:tprocdef;is_visible:boolean);
+ function newvmtentry(sym:tprocsym):pvmtentry;
+ procedure eachsym(sym : tnamedindexitem;arg:pointer);
+ procedure disposevmttree;
+ procedure writevirtualmethods(List:TAAsmoutput);
+ private
+ { interface tables }
+ function gintfgetvtbllabelname(intfindex: integer): string;
+ procedure gintfcreatevtbl(intfindex: integer; rawdata: TAAsmoutput);
+ procedure gintfgenentry(intfindex, contintfindex: integer; rawdata: TAAsmoutput);
+ procedure gintfoptimizevtbls;
+ procedure gintfwritedata;
+ function gintfgetcprocdef(proc: tprocdef;const name: string): tprocdef;
+ procedure gintfdoonintf(intf: tobjectdef; intfindex: longint);
+ procedure gintfwalkdowninterface(intf: tobjectdef; intfindex: longint);
+ public
+ constructor create(c:tobjectdef);
+ destructor destroy;override;
+ { generates the message tables for a class }
+ function genstrmsgtab : tasmlabel;
+ function genintmsgtab : tasmlabel;
+ function genpublishedmethodstable : tasmlabel;
+ { generates a VMT entries }
+ procedure genvmt;
+{$ifdef WITHDMT}
+ { generates a DMT for _class }
+ function gendmt : tasmlabel;
+{$endif WITHDMT}
+ { interfaces }
+ function genintftable: tasmlabel;
+ { write the VMT to al_globals }
+ procedure writevmt;
+ procedure writeinterfaceids;
+ end;
+
+
+implementation
+
+ uses
+ strings,
+ globals,verbose,systems,
+ symtable,symconst,symtype,defcmp,
+ dbgbase
+ ;
+
+
+{*****************************************************************************
+ TClassHeader
+*****************************************************************************}
+
+ constructor tclassheader.create(c:tobjectdef);
+ begin
+ inherited Create;
+ _Class:=c;
+ end;
+
+
+ destructor tclassheader.destroy;
+ begin
+ disposevmttree;
+ end;
+
+
+{**************************************
+ Message Tables
+**************************************}
+
+ procedure tclassheader.disposeprocdeftree(p : pprocdeftree);
+ begin
+ if assigned(p^.l) then
+ disposeprocdeftree(p^.l);
+ if assigned(p^.r) then
+ disposeprocdeftree(p^.r);
+ dispose(p);
+ end;
+
+
+ procedure tclassheader.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.i<at^.data.messageinf.i then
+ insertint(p,at^.l,count)
+ else if p^.data.messageinf.i>at^.data.messageinf.i then
+ insertint(p,at^.r,count)
+ else
+ Message1(parser_e_duplicate_message_label,tostr(p^.data.messageinf.i));
+ end;
+ end;
+
+ procedure tclassheader.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:=strcomp(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,strpas(p^.data.messageinf.str));
+ end;
+ end;
+
+ procedure tclassheader.insertmsgint(p : tnamedindexitem;arg:pointer);
+
+ var
+ i : cardinal;
+ def: Tprocdef;
+ pt : pprocdeftree;
+
+ begin
+ if tsym(p).typ=procsym then
+ for i:=1 to Tprocsym(p).procdef_count do
+ begin
+ def:=Tprocsym(p).procdef[i];
+ if po_msgint in def.procoptions then
+ begin
+ new(pt);
+ pt^.data:=def;
+ pt^.l:=nil;
+ pt^.r:=nil;
+ insertint(pt,root,plongint(arg)^);
+ end;
+ end;
+ end;
+
+ procedure tclassheader.insertmsgstr(p : tnamedindexitem;arg:pointer);
+
+ var
+ i : cardinal;
+ def: Tprocdef;
+ pt : pprocdeftree;
+
+ begin
+ if tsym(p).typ=procsym then
+ for i:=1 to Tprocsym(p).procdef_count do
+ begin
+ def:=Tprocsym(p).procdef[i];
+ if po_msgstr in def.procoptions then
+ begin
+ new(pt);
+ pt^.data:=def;
+ pt^.l:=nil;
+ pt^.r:=nil;
+ insertstr(pt,root,plongint(arg)^);
+ end;
+ end;
+ end;
+
+ procedure tclassheader.writenames(p : pprocdeftree);
+ var
+ ca : pchar;
+ len : longint;
+ begin
+ objectlibrary.getdatalabel(p^.nl);
+ if assigned(p^.l) then
+ writenames(p^.l);
+ asmlist[al_globals].concat(cai_align.create(const_align(sizeof(aint))));
+ asmlist[al_globals].concat(Tai_label.Create(p^.nl));
+ len:=strlen(p^.data.messageinf.str);
+ asmlist[al_globals].concat(tai_const.create_8bit(len));
+ getmem(ca,len+1);
+ move(p^.data.messageinf.str^,ca^,len+1);
+ asmlist[al_globals].concat(Tai_string.Create_pchar(ca,len));
+ if assigned(p^.r) then
+ writenames(p^.r);
+ end;
+
+ procedure tclassheader.writestrentry(p : pprocdeftree);
+
+ begin
+ if assigned(p^.l) then
+ writestrentry(p^.l);
+
+ { write name label }
+ asmlist[al_globals].concat(Tai_const.Create_sym(p^.nl));
+ asmlist[al_globals].concat(Tai_const.Createname(p^.data.mangledname,AT_FUNCTION,0));
+
+ if assigned(p^.r) then
+ writestrentry(p^.r);
+ end;
+
+
+ function tclassheader.genstrmsgtab : tasmlabel;
+ var
+ r : tasmlabel;
+ count : longint;
+ begin
+ root:=nil;
+ count:=0;
+ { insert all message handlers into a tree, sorted by name }
+ _class.symtable.foreach(@insertmsgstr,@count);
+
+ { write all names }
+ if assigned(root) then
+ writenames(root);
+
+ { now start writing of the message string table }
+ objectlibrary.getdatalabel(r);
+ asmlist[al_globals].concat(cai_align.create(const_align(sizeof(aint))));
+ asmlist[al_globals].concat(Tai_label.Create(r));
+ genstrmsgtab:=r;
+ asmlist[al_globals].concat(Tai_const.Create_32bit(count));
+ if assigned(root) then
+ begin
+ writestrentry(root);
+ disposeprocdeftree(root);
+ end;
+ end;
+
+
+ procedure tclassheader.writeintentry(p : pprocdeftree);
+ begin
+ if assigned(p^.l) then
+ writeintentry(p^.l);
+
+ { write name label }
+ asmlist[al_globals].concat(Tai_const.Create_32bit(p^.data.messageinf.i));
+ asmlist[al_globals].concat(Tai_const.Createname(p^.data.mangledname,AT_FUNCTION,0));
+
+ if assigned(p^.r) then
+ writeintentry(p^.r);
+ end;
+
+
+ function tclassheader.genintmsgtab : tasmlabel;
+ var
+ r : tasmlabel;
+ count : longint;
+ begin
+ root:=nil;
+ count:=0;
+ { insert all message handlers into a tree, sorted by name }
+ _class.symtable.foreach(@insertmsgint,@count);
+
+ { now start writing of the message string table }
+ objectlibrary.getdatalabel(r);
+ asmlist[al_globals].concat(cai_align.create(const_align(sizeof(aint))));
+ asmlist[al_globals].concat(Tai_label.Create(r));
+ genintmsgtab:=r;
+ asmlist[al_globals].concat(Tai_const.Create_32bit(count));
+ if assigned(root) then
+ begin
+ writeintentry(root);
+ disposeprocdeftree(root);
+ end;
+ end;
+
+{$ifdef WITHDMT}
+
+{**************************************
+ DMT
+**************************************}
+
+ procedure tclassheader.insertdmtentry(p : tnamedindexitem;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 tclassheader.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 tclassheader.writedmtaddressentry(p : pprocdeftree);
+
+ begin
+ if assigned(p^.l) then
+ writedmtaddressentry(p^.l);
+ al_globals.concat(Tai_const_symbol.Createname(p^.data.mangledname,AT_FUNCTION,0));
+ if assigned(p^.r) then
+ writedmtaddressentry(p^.r);
+ end;
+
+ function tclassheader.gendmt : tasmlabel;
+
+ var
+ r : tasmlabel;
+
+ begin
+ root:=nil;
+ count:=0;
+ gendmt:=nil;
+ { insert all message handlers into a tree, sorted by number }
+ _class.symtable.foreach(insertdmtentry);
+
+ if count>0 then
+ begin
+ objectlibrary.getdatalabel(r);
+ gendmt:=r;
+ al_globals.concat(cai_align.create(const_align(sizeof(aint))));
+ 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 tclassheader.do_count_published_methods(p : tnamedindexitem;arg:pointer);
+ var
+ i : longint;
+ pd : tprocdef;
+ begin
+ if (tsym(p).typ=procsym) then
+ begin
+ for i:=1 to tprocsym(p).procdef_count do
+ begin
+ pd:=tprocsym(p).procdef[i];
+ if (pd.procsym=tsym(p)) and
+ (sp_published in pd.symoptions) then
+ inc(plongint(arg)^);
+ end;
+ end;
+ end;
+
+
+ procedure tclassheader.do_gen_published_methods(p : tnamedindexitem;arg:pointer);
+ var
+ i : longint;
+ l : tasmlabel;
+ pd : tprocdef;
+ begin
+ if (tsym(p).typ=procsym) then
+ begin
+ for i:=1 to tprocsym(p).procdef_count do
+ begin
+ pd:=tprocsym(p).procdef[i];
+ if (pd.procsym=tsym(p)) and
+ (sp_published in pd.symoptions) then
+ begin
+ objectlibrary.getdatalabel(l);
+
+ asmlist[al_typedconsts].concat(cai_align.create(const_align(sizeof(aint))));
+ asmlist[al_typedconsts].concat(Tai_label.Create(l));
+ asmlist[al_typedconsts].concat(Tai_const.Create_8bit(length(tsym(p).realname)));
+ asmlist[al_typedconsts].concat(Tai_string.Create(tsym(p).realname));
+
+ asmlist[al_globals].concat(Tai_const.Create_sym(l));
+ if po_abstractmethod in pd.procoptions then
+ asmlist[al_globals].concat(Tai_const.Create_sym(nil))
+ else
+ asmlist[al_globals].concat(Tai_const.Createname(pd.mangledname,AT_FUNCTION,0));
+ end;
+ end;
+ end;
+ end;
+
+
+ function tclassheader.genpublishedmethodstable : tasmlabel;
+
+ var
+ l : tasmlabel;
+ count : longint;
+
+ begin
+ count:=0;
+ _class.symtable.foreach(@do_count_published_methods,@count);
+ if count>0 then
+ begin
+ objectlibrary.getdatalabel(l);
+ asmlist[al_globals].concat(cai_align.create(const_align(sizeof(aint))));
+ asmlist[al_globals].concat(Tai_label.Create(l));
+ asmlist[al_globals].concat(Tai_const.Create_32bit(count));
+ _class.symtable.foreach(@do_gen_published_methods,nil);
+ genpublishedmethodstable:=l;
+ end
+ else
+ genpublishedmethodstable:=nil;
+ end;
+
+
+{**************************************
+ VMT
+**************************************}
+
+
+ procedure tclassheader.newdefentry(vmtentry:pvmtentry;pd:tprocdef;is_visible:boolean);
+ var
+ procdefcoll : pprocdefcoll;
+ begin
+ if (_class=pd._class) then
+ 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 aktmodeswitches) then
+ begin
+ procdefcoll:=vmtentry^.firstprocdef;
+ while assigned(procdefcoll) do
+ begin
+ if (procdefcoll^.data._class=pd._class) and
+ ((po_overload in pd.procoptions)<>(po_overload in procdefcoll^.data.procoptions)) then
+ begin
+ MessagePos1(pd.fileinfo,parser_e_no_overload_for_all_procs,pd.procsym.realname);
+ { recover }
+ include(procdefcoll^.data.procoptions,po_overload);
+ include(pd.procoptions,po_overload);
+ end;
+ procdefcoll:=procdefcoll^.next;
+ end;
+ end;
+ end;
+
+ { generate new entry }
+ new(procdefcoll);
+ procdefcoll^.data:=pd;
+ procdefcoll^.hidden:=false;
+ procdefcoll^.visible:=is_visible;
+ procdefcoll^.next:=vmtentry^.firstprocdef;
+ vmtentry^.firstprocdef:=procdefcoll;
+
+ { give virtual method a number }
+ if (po_virtualmethod in pd.procoptions) then
+ begin
+ pd.extnumber:=nextvirtnumber;
+ inc(nextvirtnumber);
+ has_virtual_method:=true;
+ end;
+
+ if (pd.proctypeoption=potype_constructor) then
+ has_constructor:=true;
+ end;
+
+
+ function tclassheader.newvmtentry(sym:tprocsym):pvmtentry;
+ begin
+ { generate new vmtentry }
+ new(result);
+ result^.speedvalue:=sym.speedvalue;
+ result^.name:=stringdup(sym.name);
+ result^.next:=firstvmtentry;
+ result^.firstprocdef:=nil;
+ firstvmtentry:=result;
+ end;
+
+
+ procedure tclassheader.eachsym(sym : tnamedindexitem;arg:pointer);
+ const
+ po_comp = [po_classmethod,po_virtualmethod,po_staticmethod,po_interrupt,po_iocheck,po_msgstr,po_msgint,
+ po_exports,po_varargs,po_explicitparaloc,po_nostackframe];
+ label
+ handlenextdef;
+ var
+ pd : tprocdef;
+ i : cardinal;
+ is_visible,
+ hasoverloads,
+ pdoverload : boolean;
+ procdefcoll : pprocdefcoll;
+ vmtentry : pvmtentry;
+ _name : string;
+ _speed : cardinal;
+ begin
+ if (tsym(sym).typ<>procsym) then
+ exit;
+
+ { check the current list of symbols }
+ _name:=sym.name;
+ _speed:=sym.speedvalue;
+ vmtentry:=firstvmtentry;
+ while assigned(vmtentry) do
+ begin
+ { does the symbol already exist in the list? First
+ compare speedvalue before doing the string compare to
+ speed it up a little }
+ if (_speed=vmtentry^.speedvalue) and
+ (_name=vmtentry^.name^) then
+ begin
+ hasoverloads:=(Tprocsym(sym).procdef_count>1);
+ { walk through all defs of the symbol }
+ for i:=1 to Tprocsym(sym).procdef_count do
+ begin
+ pd:=Tprocsym(sym).procdef[i];
+
+ { is this procdef visible from the class that we are
+ generating. This will be used to hide the other procdefs.
+ When the symbol is not visible we don't hide the other
+ procdefs, because they can be reused in the next class.
+ The check to skip the invisible methods that are in the
+ list is futher down in the code }
+ is_visible:=pd.is_visible_for_object(_class);
+
+ if pd.procsym=sym then
+ begin
+ pdoverload:=(po_overload in pd.procoptions);
+
+ { compare with all stored definitions }
+ procdefcoll:=vmtentry^.firstprocdef;
+ while assigned(procdefcoll) do
+ begin
+ { compare only if the definition is not hidden }
+ if not procdefcoll^.hidden then
+ begin
+ { check if one of the two methods has virtual }
+ if (po_virtualmethod in procdefcoll^.data.procoptions) or
+ (po_virtualmethod in pd.procoptions) then
+ begin
+ { if the current definition has no virtual then hide the
+ old virtual if the new definition has the same arguments or
+ when it has no overload directive and no overloads }
+ if not(po_virtualmethod in pd.procoptions) then
+ begin
+ if procdefcoll^.visible and
+ (not(pdoverload or hasoverloads) or
+ (compare_paras(procdefcoll^.data.paras,pd.paras,cp_all,[])>=te_equal)) then
+ begin
+ if is_visible then
+ procdefcoll^.hidden:=true;
+ if (_class=pd._class) and not(po_reintroduce in pd.procoptions) then
+ MessagePos1(pd.fileinfo,parser_w_should_use_override,pd.fullprocname(false));
+ end;
+ end
+ { if both are virtual we check the header }
+ else if (po_virtualmethod in pd.procoptions) and
+ (po_virtualmethod in procdefcoll^.data.procoptions) then
+ begin
+ { new one has not override }
+ if is_class(_class) and
+ not(po_overridingmethod in pd.procoptions) then
+ begin
+ { we start a new virtual tree, hide the old }
+ if (not(pdoverload or hasoverloads) or
+ (compare_paras(procdefcoll^.data.paras,pd.paras,cp_all,[])>=te_equal)) and
+ (procdefcoll^.visible) then
+ begin
+ if is_visible then
+ procdefcoll^.hidden:=true;
+ if (_class=pd._class) and not(po_reintroduce in pd.procoptions) then
+ MessagePos1(pd.fileinfo,parser_w_should_use_override,pd.fullprocname(false));
+ end;
+ end
+ { same parameters }
+ else if (compare_paras(procdefcoll^.data.paras,pd.paras,cp_all,[])>=te_equal) then
+ begin
+ { overload is inherited }
+ if (po_overload in procdefcoll^.data.procoptions) then
+ include(pd.procoptions,po_overload);
+
+ { inherite calling convention when it was force and the
+ current definition has none force }
+ if (po_hascallingconvention in procdefcoll^.data.procoptions) and
+ not(po_hascallingconvention in pd.procoptions) then
+ begin
+ pd.proccalloption:=procdefcoll^.data.proccalloption;
+ include(pd.procoptions,po_hascallingconvention);
+ end;
+
+ { the flags have to match except abstract and override }
+ { only if both are virtual !! }
+ if (procdefcoll^.data.proccalloption<>pd.proccalloption) or
+ (procdefcoll^.data.proctypeoption<>pd.proctypeoption) or
+ ((procdefcoll^.data.procoptions*po_comp)<>(pd.procoptions*po_comp)) then
+ begin
+ MessagePos1(pd.fileinfo,parser_e_header_dont_match_forward,pd.fullprocname(false));
+ tprocsym(procdefcoll^.data.procsym).write_parameter_lists(pd);
+ end;
+
+ { error, if the return types aren't equal }
+ if not(equal_defs(procdefcoll^.data.rettype.def,pd.rettype.def)) and
+ not((procdefcoll^.data.rettype.def.deftype=objectdef) and
+ (pd.rettype.def.deftype=objectdef) and
+ is_class(procdefcoll^.data.rettype.def) and
+ is_class(pd.rettype.def) and
+ (tobjectdef(pd.rettype.def).is_related(
+ tobjectdef(procdefcoll^.data.rettype.def)))) then
+ Message2(parser_e_overridden_methods_not_same_ret,pd.fullprocname(false),
+ procdefcoll^.data.fullprocname(false));
+
+ { check if the method to override is visible, check is only needed
+ for the current parsed class. Parent classes are already validated and
+ need to include all virtual methods including the ones not visible in the
+ current class }
+ if (_class=pd._class) and
+ (po_overridingmethod in pd.procoptions) and
+ (not procdefcoll^.visible) then
+ MessagePos1(pd.fileinfo,parser_e_nothing_to_be_overridden,pd.fullprocname(false));
+
+ { override old virtual method in VMT }
+ pd.extnumber:=procdefcoll^.data.extnumber;
+ procdefcoll^.data:=pd;
+ if is_visible then
+ procdefcoll^.visible:=true;
+
+ goto handlenextdef;
+ 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 then
+ begin
+ if is_visible then
+ procdefcoll^.hidden:=true;
+ if (_class=pd._class) and not(po_reintroduce in pd.procoptions) then
+ MessagePos1(pd.fileinfo,parser_w_should_use_override,pd.fullprocname(false));
+ end;
+ end;
+ end
+ else
+ begin
+ { the new definition is virtual and the old static, we hide the old one
+ if the new defintion has not the overload directive }
+ if is_visible and
+ ((not(pdoverload or hasoverloads)) or
+ (compare_paras(procdefcoll^.data.paras,pd.paras,cp_all,[])>=te_equal)) then
+ procdefcoll^.hidden:=true;
+ end;
+ end
+ else
+ begin
+ { both are static, we hide the old one if the new defintion
+ has not the overload directive }
+ if is_visible and
+ ((not pdoverload) or
+ (compare_paras(procdefcoll^.data.paras,pd.paras,cp_all,[])>=te_equal)) then
+ procdefcoll^.hidden:=true;
+ end;
+ end; { not hidden }
+ procdefcoll:=procdefcoll^.next;
+ end;
+
+ { if it isn't saved in the list we create a new entry }
+ newdefentry(vmtentry,pd,is_visible);
+ end;
+ handlenextdef:
+ end;
+ exit;
+ end;
+ vmtentry:=vmtentry^.next;
+ end;
+
+ { Generate new procsym entry in vmt }
+ vmtentry:=newvmtentry(tprocsym(sym));
+
+ { Add procdefs }
+ for i:=1 to Tprocsym(sym).procdef_count do
+ begin
+ pd:=Tprocsym(sym).procdef[i];
+ newdefentry(vmtentry,pd,pd.is_visible_for_object(_class));
+ end;
+ end;
+
+
+ procedure tclassheader.disposevmttree;
+ var
+ vmtentry : pvmtentry;
+ procdefcoll : pprocdefcoll;
+ begin
+ { disposes the above generated tree }
+ vmtentry:=firstvmtentry;
+ while assigned(vmtentry) do
+ begin
+ firstvmtentry:=vmtentry^.next;
+ stringdispose(vmtentry^.name);
+ procdefcoll:=vmtentry^.firstprocdef;
+ while assigned(procdefcoll) do
+ begin
+ vmtentry^.firstprocdef:=procdefcoll^.next;
+ dispose(procdefcoll);
+ procdefcoll:=vmtentry^.firstprocdef;
+ end;
+ dispose(vmtentry);
+ vmtentry:=firstvmtentry;
+ end;
+ end;
+
+
+ procedure tclassheader.genvmt;
+
+ procedure do_genvmt(p : tobjectdef);
+
+ begin
+ { start with the base class }
+ if assigned(p.childof) then
+ do_genvmt(p.childof);
+
+ { walk through all public syms }
+ p.symtable.foreach(@eachsym,nil);
+ end;
+
+ begin
+ firstvmtentry:=nil;
+ nextvirtnumber:=0;
+
+ has_constructor:=false;
+ has_virtual_method:=false;
+
+ { generates a tree of all used methods }
+ do_genvmt(_class);
+
+ if not(is_interface(_class)) and
+ has_virtual_method and
+ not(has_constructor) then
+ Message1(parser_w_virtual_without_constructor,_class.objrealname^);
+ end;
+
+
+{**************************************
+ Interface tables
+**************************************}
+
+ function tclassheader.gintfgetvtbllabelname(intfindex: integer): string;
+ begin
+ gintfgetvtbllabelname:=make_mangledname('VTBL',_class.owner,_class.objname^+
+ '_$_'+_class.implementedinterfaces.interfaces(intfindex).objname^);
+ end;
+
+
+ procedure tclassheader.gintfcreatevtbl(intfindex: integer; rawdata: TAAsmoutput);
+ var
+ implintf: timplementedinterfaces;
+ curintf: tobjectdef;
+ proccount: integer;
+ tmps: string;
+ i: longint;
+ begin
+ implintf:=_class.implementedinterfaces;
+ curintf:=implintf.interfaces(intfindex);
+
+ section_symbol_start(rawdata,gintfgetvtbllabelname(intfindex),AT_DATA,true,sec_data,const_align(sizeof(aint)));
+ proccount:=implintf.implproccount(intfindex);
+ for i:=1 to proccount do
+ begin
+ tmps:=make_mangledname('WRPR',_class.owner,_class.objname^+'_$_'+curintf.objname^+'_$_'+
+ tostr(i)+'_$_'+
+ implintf.implprocs(intfindex,i).mangledname);
+ { create reference }
+ rawdata.concat(Tai_const.Createname(tmps,AT_FUNCTION,0));
+ end;
+ section_symbol_end(rawdata,gintfgetvtbllabelname(intfindex));
+ end;
+
+
+ procedure tclassheader.gintfgenentry(intfindex, contintfindex: integer; rawdata: TAAsmoutput);
+ var
+ implintf: timplementedinterfaces;
+ curintf: tobjectdef;
+ tmplabel: tasmlabel;
+ i: longint;
+ begin
+ implintf:=_class.implementedinterfaces;
+ curintf:=implintf.interfaces(intfindex);
+ { GUID }
+ if curintf.objecttype in [odt_interfacecom] then
+ begin
+ { label for GUID }
+ objectlibrary.getdatalabel(tmplabel);
+ rawdata.concat(cai_align.create(const_align(sizeof(aint))));
+ rawdata.concat(Tai_label.Create(tmplabel));
+ rawdata.concat(Tai_const.Create_32bit(longint(curintf.iidguid^.D1)));
+ rawdata.concat(Tai_const.Create_16bit(curintf.iidguid^.D2));
+ rawdata.concat(Tai_const.Create_16bit(curintf.iidguid^.D3));
+ for i:=Low(curintf.iidguid^.D4) to High(curintf.iidguid^.D4) do
+ rawdata.concat(Tai_const.Create_8bit(curintf.iidguid^.D4[i]));
+ asmlist[al_globals].concat(Tai_const.Create_sym(tmplabel));
+ end
+ else
+ begin
+ { nil for Corba interfaces }
+ asmlist[al_globals].concat(Tai_const.Create_sym(nil));
+ end;
+ { VTable }
+ asmlist[al_globals].concat(Tai_const.Createname(gintfgetvtbllabelname(contintfindex),AT_DATA,0));
+ { IOffset field }
+ asmlist[al_globals].concat(Tai_const.Create_32bit(implintf.ioffsets(contintfindex)));
+ { IIDStr }
+ objectlibrary.getdatalabel(tmplabel);
+ rawdata.concat(cai_align.create(const_align(sizeof(aint))));
+ rawdata.concat(Tai_label.Create(tmplabel));
+ rawdata.concat(Tai_const.Create_8bit(length(curintf.iidstr^)));
+ if curintf.objecttype=odt_interfacecom then
+ rawdata.concat(Tai_string.Create(upper(curintf.iidstr^)))
+ else
+ rawdata.concat(Tai_string.Create(curintf.iidstr^));
+ asmlist[al_globals].concat(Tai_const.Create_sym(tmplabel));
+ end;
+
+
+ procedure tclassheader.gintfoptimizevtbls;
+ type
+ tcompintfentry = record
+ weight: longint;
+ compintf: longint;
+ end;
+ { Max 1000 interface in the class header interfaces it's enough imho }
+ tcompintfs = array[1..1000] of tcompintfentry;
+ pcompintfs = ^tcompintfs;
+ tequals = array[1..1000] of longint;
+ pequals = ^tequals;
+ timpls = array[1..1000] of longint;
+ pimpls = ^timpls;
+ var
+ max: longint;
+ equals: pequals;
+ compats: pcompintfs;
+ impls: pimpls;
+ w,i,j,k: longint;
+ cij: boolean;
+ cji: boolean;
+ begin
+ max:=_class.implementedinterfaces.count;
+ if max>High(tequals) then
+ Internalerror(200006135);
+ getmem(compats,sizeof(tcompintfentry)*max);
+ getmem(equals,sizeof(longint)*max);
+ getmem(impls,sizeof(longint)*max);
+ fillchar(compats^,sizeof(tcompintfentry)*max,0);
+ fillchar(equals^,sizeof(longint)*max,0);
+ fillchar(impls^,sizeof(longint)*max,0);
+ { 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:=1 to max do
+ begin
+ for j:=i+1 to max do
+ begin
+ cij:=_class.implementedinterfaces.isimplmergepossible(i,j,w);
+ cji:=_class.implementedinterfaces.isimplmergepossible(j,i,w);
+ if cij and cji then { i equal j }
+ begin
+ { get minimum index of equal }
+ if equals^[j]=0 then
+ equals^[j]:=i;
+ end
+ else if cij then
+ begin
+ { get minimum index of maximum weight }
+ if compats^[i].weight<w then
+ begin
+ compats^[i].weight:=w;
+ compats^[i].compintf:=j;
+ end;
+ end
+ else if cji then
+ begin
+ { get minimum index of maximum weight }
+ if (compats^[j].weight<w) then
+ begin
+ compats^[j].weight:=w;
+ compats^[j].compintf:=i;
+ end;
+ end;
+ end;
+ end;
+ { Reset, no replacements by default }
+ for i:=1 to max do
+ impls^[i]:=i;
+ { Replace vtbls when equal or compat, repeat
+ until there are no replacements possible anymore. This is
+ needed for the cases like:
+ First loop: 2->3, 3->1
+ Second loop: 2->1 (because 3 was replaced with 1)
+ }
+ repeat
+ k:=0;
+ for i:=1 to max do
+ begin
+ if compats^[impls^[i]].compintf<>0 then
+ impls^[i]:=compats^[impls^[i]].compintf
+ else if equals^[impls^[i]]<>0 then
+ impls^[i]:=equals^[impls^[i]]
+ else
+ inc(k);
+ end;
+ until k=max;
+ { Update the implindex }
+ for i:=1 to max do
+ _class.implementedinterfaces.setimplindex(i,impls^[i]);
+ freemem(compats);
+ freemem(equals);
+ freemem(impls);
+ end;
+
+
+ procedure tclassheader.gintfwritedata;
+ var
+ rawdata: taasmoutput;
+ max,i,j : smallint;
+ begin
+ max:=_class.implementedinterfaces.count;
+
+ rawdata:=TAAsmOutput.Create;
+ asmlist[al_globals].concat(Tai_const.Create_16bit(max));
+ { Two pass, one for allocation and vtbl creation }
+ for i:=1 to max do
+ begin
+ if _class.implementedinterfaces.implindex(i)=i then { if implement itself }
+ begin
+ { allocate a pointer in the object memory }
+ with tobjectsymtable(_class.symtable) do
+ begin
+ datasize:=align(datasize,min(sizeof(aint),fieldalignment));
+ _class.implementedinterfaces.setioffsets(i,datasize);
+ inc(datasize,sizeof(aint));
+ end;
+ { write vtbl }
+ gintfcreatevtbl(i,rawdata);
+ end;
+ end;
+ { second pass: for fill interfacetable and remained ioffsets }
+ for i:=1 to max do
+ begin
+ j:=_class.implementedinterfaces.implindex(i);
+ if j<>i then
+ _class.implementedinterfaces.setioffsets(i,_class.implementedinterfaces.ioffsets(j));
+ gintfgenentry(i,j,rawdata);
+ end;
+ asmlist[al_globals].concatlist(rawdata);
+ rawdata.free;
+ end;
+
+
+ function tclassheader.gintfgetcprocdef(proc: tprocdef;const name: string): tprocdef;
+ const
+ po_comp = [po_classmethod,po_staticmethod,po_interrupt,po_iocheck,po_msgstr,po_msgint,
+ po_exports,po_varargs,po_explicitparaloc,po_nostackframe];
+ var
+ sym: tsym;
+ implprocdef : Tprocdef;
+ i: cardinal;
+ begin
+ gintfgetcprocdef:=nil;
+
+ sym:=tsym(search_class_member(_class,name));
+ if assigned(sym) and
+ (sym.typ=procsym) then
+ begin
+ { when the definition has overload directive set, we search for
+ overloaded definitions in the class, this only needs to be done once
+ for class entries as the tree keeps always the same }
+ if (not tprocsym(sym).overloadchecked) and
+ (po_overload in tprocsym(sym).first_procdef.procoptions) and
+ (tprocsym(sym).owner.symtabletype=objectsymtable) then
+ search_class_overloads(tprocsym(sym));
+
+ for i:=1 to tprocsym(sym).procdef_count do
+ begin
+ implprocdef:=tprocsym(sym).procdef[i];
+ if (compare_paras(proc.paras,implprocdef.paras,cp_none,[])>=te_equal) and
+ (proc.proccalloption=implprocdef.proccalloption) and
+ (proc.proctypeoption=implprocdef.proctypeoption) and
+ ((proc.procoptions*po_comp)=((implprocdef.procoptions+[po_virtualmethod])*po_comp)) then
+ begin
+ gintfgetcprocdef:=implprocdef;
+ exit;
+ end;
+ end;
+ end;
+ end;
+
+
+ procedure tclassheader.gintfdoonintf(intf: tobjectdef; intfindex: longint);
+ var
+ def: tdef;
+ hs,
+ mappedname: string;
+ nextexist: pointer;
+ implprocdef: tprocdef;
+ begin
+ def:=tdef(intf.symtable.defindex.first);
+ while assigned(def) do
+ begin
+ if def.deftype=procdef then
+ begin
+ implprocdef:=nil;
+ nextexist:=nil;
+ repeat
+ hs:=intf.symtable.name^+'.'+tprocdef(def).procsym.name;
+ mappedname:=_class.implementedinterfaces.getmappings(intfindex,hs,nextexist);
+ if mappedname<>'' then
+ implprocdef:=gintfgetcprocdef(tprocdef(def),mappedname);
+ until assigned(implprocdef) or not assigned(nextexist);
+ if not assigned(implprocdef) then
+ implprocdef:=gintfgetcprocdef(tprocdef(def),tprocdef(def).procsym.name);
+ if assigned(implprocdef) then
+ _class.implementedinterfaces.addimplproc(intfindex,implprocdef)
+ else
+ Message1(sym_e_no_matching_implementation_found,tprocdef(def).fullprocname(false));
+ end;
+ def:=tdef(def.indexnext);
+ end;
+ end;
+
+
+ procedure tclassheader.gintfwalkdowninterface(intf: tobjectdef; intfindex: longint);
+ begin
+ if assigned(intf.childof) then
+ gintfwalkdowninterface(intf.childof,intfindex);
+ gintfdoonintf(intf,intfindex);
+ end;
+
+
+ function tclassheader.genintftable: tasmlabel;
+ var
+ intfindex: longint;
+ curintf: tobjectdef;
+ intftable: tasmlabel;
+ begin
+ { 1. step collect implementor functions into the implementedinterfaces.implprocs }
+ for intfindex:=1 to _class.implementedinterfaces.count do
+ begin
+ curintf:=_class.implementedinterfaces.interfaces(intfindex);
+ gintfwalkdowninterface(curintf,intfindex);
+ end;
+ { 2. step calc required fieldcount and their offsets in the object memory map
+ and write data }
+ objectlibrary.getdatalabel(intftable);
+ asmlist[al_globals].concat(cai_align.create(const_align(sizeof(aint))));
+ asmlist[al_globals].concat(Tai_label.Create(intftable));
+ { Optimize interface tables to reuse wrappers }
+ gintfoptimizevtbls;
+ { Write interface tables }
+ gintfwritedata;
+ genintftable:=intftable;
+ end;
+
+
+ { Write interface identifiers to the data section }
+ procedure tclassheader.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(asmlist[al_globals]);
+ new_section(asmlist[al_globals],sec_rodata,s,const_align(sizeof(aint)));
+ asmlist[al_globals].concat(Tai_symbol.Createname_global(s,AT_DATA,0));
+ asmlist[al_globals].concat(Tai_const.Create_32bit(longint(_class.iidguid^.D1)));
+ asmlist[al_globals].concat(Tai_const.Create_16bit(_class.iidguid^.D2));
+ asmlist[al_globals].concat(Tai_const.Create_16bit(_class.iidguid^.D3));
+ for i:=Low(_class.iidguid^.D4) to High(_class.iidguid^.D4) do
+ asmlist[al_globals].concat(Tai_const.Create_8bit(_class.iidguid^.D4[i]));
+ end;
+ maybe_new_object_file(asmlist[al_globals]);
+ s:=make_mangledname('IIDSTR',_class.owner,_class.objname^);
+ new_section(asmlist[al_globals],sec_rodata,s,0);
+ asmlist[al_globals].concat(Tai_symbol.Createname_global(s,AT_DATA,0));
+ asmlist[al_globals].concat(Tai_const.Create_8bit(length(_class.iidstr^)));
+ asmlist[al_globals].concat(Tai_string.Create(_class.iidstr^));
+ end;
+
+
+ procedure tclassheader.writevirtualmethods(List:TAAsmoutput);
+ var
+ vmtentry : pvmtentry;
+ procdefcoll : pprocdefcoll;
+ i : longint;
+ begin
+ { walk trough all numbers for virtual methods and search }
+ { the method }
+ for i:=0 to nextvirtnumber-1 do
+ begin
+ { walk trough all symbols }
+ vmtentry:=firstvmtentry;
+ while assigned(vmtentry) do
+ begin
+ { walk trough all methods }
+ procdefcoll:=vmtentry^.firstprocdef;
+ while assigned(procdefcoll) do
+ begin
+ { writes the addresses to the VMT }
+ { but only this which are declared as virtual }
+ if procdefcoll^.data.extnumber=i then
+ begin
+ if (po_virtualmethod in procdefcoll^.data.procoptions) then
+ begin
+ { if a method is abstract, then is also the }
+ { class abstract and it's not allow to }
+ { generates an instance }
+ if (po_abstractmethod in procdefcoll^.data.procoptions) then
+ List.concat(Tai_const.Createname('FPC_ABSTRACTERROR',AT_FUNCTION,0))
+ else
+ List.concat(Tai_const.createname(procdefcoll^.data.mangledname,AT_FUNCTION,0));
+ end;
+ end;
+ procdefcoll:=procdefcoll^.next;
+ end;
+ vmtentry:=vmtentry^.next;
+ end;
+ end;
+ end;
+
+ { generates the vmt for classes as well as for objects }
+ procedure tclassheader.writevmt;
+
+ var
+ methodnametable,intmessagetable,
+ strmessagetable,classnamelabel,
+ fieldtablelabel : tasmlabel;
+{$ifdef WITHDMT}
+ dmtlabel : tasmlabel;
+{$endif WITHDMT}
+ interfacetable : tasmlabel;
+ 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
+ objectlibrary.getdatalabel(classnamelabel);
+ maybe_new_object_file(asmlist[al_globals]);
+ new_section(asmlist[al_globals],sec_rodata,classnamelabel.name,const_align(sizeof(aint)));
+
+ { interface table }
+ if _class.implementedinterfaces.count>0 then
+ interfacetable:=genintftable;
+
+ methodnametable:=genpublishedmethodstable;
+ fieldtablelabel:=_class.generate_field_table;
+ { write class name }
+ asmlist[al_globals].concat(Tai_label.Create(classnamelabel));
+ asmlist[al_globals].concat(Tai_const.Create_8bit(length(_class.objrealname^)));
+ asmlist[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(asmlist[al_globals]);
+ new_section(asmlist[al_globals],sec_rodata,_class.vmt_mangledname,const_align(sizeof(aint)));
+ asmlist[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 }
+ asmlist[al_globals].concat(Tai_const.Create(ait_const_ptr,tobjectsymtable(_class.symtable).datasize));
+ asmlist[al_globals].concat(Tai_const.Create(ait_const_ptr,-int64(tobjectsymtable(_class.symtable).datasize)));
+{$ifdef WITHDMT}
+ if _class.classtype=ct_object then
+ begin
+ if assigned(dmtlabel) then
+ asmlist[al_globals].concat(Tai_const_symbol.Create(dmtlabel)))
+ else
+ asmlist[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
+ asmlist[al_globals].concat(Tai_const.Createname(_class.childof.vmt_mangledname,AT_DATA,0))
+ else
+ asmlist[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 }
+ asmlist[al_globals].concat(Tai_const.Create_sym(classnamelabel));
+ { pointer to dynamic table or nil }
+ if (oo_has_msgint in _class.objectoptions) then
+ asmlist[al_globals].concat(Tai_const.Create_sym(intmessagetable))
+ else
+ asmlist[al_globals].concat(Tai_const.Create_sym(nil));
+ { pointer to method table or nil }
+ asmlist[al_globals].concat(Tai_const.Create_sym(methodnametable));
+ { pointer to field table }
+ asmlist[al_globals].concat(Tai_const.Create_sym(fieldtablelabel));
+ { pointer to type info of published section }
+ if (oo_can_have_published in _class.objectoptions) then
+ asmlist[al_globals].concat(Tai_const.Create_sym(_class.get_rtti_label(fullrtti)))
+ else
+ asmlist[al_globals].concat(Tai_const.Create_sym(nil));
+ { inittable for con-/destruction }
+ if _class.members_need_inittable then
+ asmlist[al_globals].concat(Tai_const.Create_sym(_class.get_rtti_label(initrtti)))
+ else
+ asmlist[al_globals].concat(Tai_const.Create_sym(nil));
+ { auto table }
+ asmlist[al_globals].concat(Tai_const.Create_sym(nil));
+ { interface table }
+ if _class.implementedinterfaces.count>0 then
+ asmlist[al_globals].concat(Tai_const.Create_sym(interfacetable))
+ else
+ asmlist[al_globals].concat(Tai_const.Create_sym(nil));
+ { table for string messages }
+ if (oo_has_msgstr in _class.objectoptions) then
+ asmlist[al_globals].concat(Tai_const.Create_sym(strmessagetable))
+ else
+ asmlist[al_globals].concat(Tai_const.Create_sym(nil));
+ end;
+ { write virtual methods }
+ writevirtualmethods(asmlist[al_globals]);
+ asmlist[al_globals].concat(Tai_const.create(ait_const_ptr,0));
+ { write the size of the VMT }
+ asmlist[al_globals].concat(Tai_symbol_end.Createname(_class.vmt_mangledname));
+ end;
+
+
+end.
View Lorry Controller Status