From 59cfa402c9f21b79f7d0532f2a7473217201b3f6 Mon Sep 17 00:00:00 2001 From: daniel Date: Sat, 11 Mar 2000 21:11:24 +0000 Subject: [PATCH] * Ported hcgdata to new symtable. * Alignment code changed as suggested by Peter + Usage of my is operator replacement, is_object --- compiler/new/cgbase.pas | 11 +- compiler/new/cgobj.pas | 236 ++++++++++- compiler/new/symtable/cobjects.pas | 58 ++- compiler/new/symtable/defs.pas | 92 +++- compiler/new/symtable/hcgdata.pas | 651 +++++++++++++++++++++++++++++ compiler/new/symtable/htypechk.pas | 92 ++-- compiler/new/symtable/symbols.pas | 34 +- compiler/new/symtable/symtable.pas | 34 +- compiler/new/symtable/symtablt.pas | 105 +++-- compiler/new/symtable/xobjects.pas | 81 ++++ compiler/pbase.pas | 10 +- compiler/ptype.pas | 20 +- 12 files changed, 1320 insertions(+), 104 deletions(-) create mode 100644 compiler/new/symtable/hcgdata.pas create mode 100644 compiler/new/symtable/xobjects.pas diff --git a/compiler/new/cgbase.pas b/compiler/new/cgbase.pas index c4b360b110..54ca092885 100644 --- a/compiler/new/cgbase.pas +++ b/compiler/new/cgbase.pas @@ -60,7 +60,9 @@ unit cgbase; { current class, if we are in a method } _class : pobjectdef; { return type } - {$IFNDEF NEWST} + {$IFDEF NEWST} + retdef:Pdef; + {$ELSE} returntype : ttype; {$ENDIF NEWST} { symbol of the function, and the sym for result variable } @@ -523,7 +525,12 @@ unit cgbase; end. { $Log$ - Revision 1.18 2000-02-28 17:23:58 daniel + Revision 1.19 2000-03-11 21:11:24 daniel + * Ported hcgdata to new symtable. + * Alignment code changed as suggested by Peter + + Usage of my is operator replacement, is_object + + Revision 1.18 2000/02/28 17:23:58 daniel * Current work of symtable integration committed. The symtable can be activated by defining 'newst', but doesn't compile yet. Changes in type checking and oop are completed. What is left is to write a new diff --git a/compiler/new/cgobj.pas b/compiler/new/cgobj.pas index 1219ded7d2..8de6ac08fd 100644 --- a/compiler/new/cgobj.pas +++ b/compiler/new/cgobj.pas @@ -26,7 +26,11 @@ unit cgobj; interface uses - cobjects,aasm,symtable,symconst,cpuasm,cpubase,cgbase,cpuinfo,tainst; + cobjects,aasm,symtable,cpuasm,cpubase,cgbase,cpuinfo,tainst + {$IFDEF NEWST} + {$ELSE} + ,symconst + {$ENDIF NEWST}; type talignment = (AM_NATURAL,AM_NONE,AM_2BYTE,AM_4BYTE,AM_8BYTE); @@ -181,7 +185,10 @@ unit cgobj; uses strings,globals,globtype,options,files,gdb,systems, - ppu,verbose,types,tgobj,tgcpu; + ppu,verbose,types,tgobj,tgcpu + {$IFDEF NEWST} + ,symbols,defs,symtablt + {$ENDIF NEWST}; {***************************************************************************** basic functionallity @@ -442,6 +449,27 @@ unit cgobj; hr : treference; begin + {$IFDEF NEWST} + if (typeof(p^)=typeof(Tvarsym)) and + assigned(pvarsym(p)^.definition) and + not((typeof((pvarsym(p)^.definition^))=typeof(Tobjectdef)) and + (oo_is_class in pobjectdef(pvarsym(p)^.definition)^.options)) and + pvarsym(p)^.definition^.needs_inittable then + begin + procinfo^.flags:=procinfo^.flags or pi_needs_implicit_finally; + reset_reference(hr); + if typeof((psym(p)^.owner^))=typeof(Tprocsymtable) then + begin + hr.base:=procinfo^.framepointer; + hr.offset:=-pvarsym(p)^.address; + end + else + begin + hr.symbol:=newasmsymbol(pvarsym(p)^.mangledname); + end; + g_initialize(list,pvarsym(p)^.definition,hr,false); + end; + {$ELSE} if (psym(p)^.typ=varsym) and assigned(pvarsym(p)^.vartype.def) and not((pvarsym(p)^.vartype.def^.deftype=objectdef) and @@ -461,6 +489,7 @@ unit cgobj; end; g_initialize(list,pvarsym(p)^.vartype.def,hr,false); end; + {$ENDIF NEWST} end; @@ -471,6 +500,25 @@ unit cgobj; hr : treference; begin + {$IFDEF NEWST} + if (typeof((psym(p)^))=typeof(Tparamsym)) and + not((typeof((Pparamsym(p)^.definition^))=typeof(Tobjectdef)) and + (oo_is_class in pobjectdef(pvarsym(p)^.definition)^.options)) and + Pparamsym(p)^.definition^.needs_inittable and + ((Pparamsym(p)^.varspez=vs_value)) then + begin + procinfo^.flags:=procinfo^.flags or pi_needs_implicit_finally; + reset_reference(hr); + hr.symbol:=pvarsym(p)^.definition^.get_inittable_label; + a_param_ref_addr(list,hr,2); + reset_reference(hr); + hr.base:=procinfo^.framepointer; + hr.offset:=pvarsym(p)^.address+procinfo^.para_offset; + a_param_ref_addr(list,hr,1); + reset_reference(hr); + a_call_name(list,'FPC_ADDREF',0); + end; + {$ELSE} if (psym(p)^.typ=varsym) and not((pvarsym(p)^.vartype.def^.deftype=objectdef) and pobjectdef(pvarsym(p)^.vartype.def)^.is_class) and @@ -488,6 +536,7 @@ unit cgobj; reset_reference(hr); a_call_name(list,'FPC_ADDREF',0); end; + {$ENDIF NEWST} end; @@ -498,6 +547,36 @@ unit cgobj; hr : treference; begin + {$IFDEF NEWST} + if (typeof((psym(p)^))=typeof(Tvarsym)) and + assigned(pvarsym(p)^.definition) and + not((typeof((pvarsym(p)^.definition^))=typeof(Tobjectdef)) and + (oo_is_class in pobjectdef(pvarsym(p)^.definition)^.options)) and + pvarsym(p)^.definition^.needs_inittable then + begin + { not all kind of parameters need to be finalized } + if (typeof((psym(p)^.owner^))=typeof(Tprocsymtable)) and + ((pparamsym(p)^.varspez=vs_var) or + (Pparamsym(p)^.varspez=vs_const) { and + (dont_copy_const_param(pvarsym(p)^.definition)) } ) then + exit; + procinfo^.flags:=procinfo^.flags or pi_needs_implicit_finally; + reset_reference(hr); + if typeof((Psym(p)^.owner^))=typeof(Tprocsymtable) then + begin + hr.base:=procinfo^.framepointer; + hr.offset:=-pvarsym(p)^.address; + end + else if typeof((Psym(p)^.owner^))=typeof(Tprocsymtable) then + begin + hr.base:=procinfo^.framepointer; + hr.offset:=pvarsym(p)^.address+procinfo^.para_offset; + end + else + hr.symbol:=newasmsymbol(pvarsym(p)^.mangledname); + g_finalize(list,pvarsym(p)^.definition,hr,false); + end; + {$ELSE} if (psym(p)^.typ=varsym) and assigned(pvarsym(p)^.vartype.def) and not((pvarsym(p)^.vartype.def^.deftype=objectdef) and @@ -528,6 +607,7 @@ unit cgobj; end; g_finalize(list,pvarsym(p)^.vartype.def,hr,false); end; + {$ENDIF NEWST} end; @@ -543,11 +623,13 @@ unit cgobj; { wrappers for the methods, because TP doesn't know procedures } { of objects } + {$IFNDEF NEWST} procedure _copyvalueparas(s : pnamedindexobject);{$ifndef FPC}far;{$endif} begin cg^.g_copyvalueparas(_list,s); end; + {$ENDIF NEWST} procedure tcg.g_finalizetempansistrings(list : paasmoutput); @@ -572,6 +654,24 @@ unit cgobj; end; end; + {$IFDEF NEWST} + procedure _initialize_local(s:Pnamedindexobject);{$IFNDEF FPC}far;{$ENDIF} + + begin + if typeof(s^)=typeof(Tparamsym) then + cg^.g_incr_data(_list,Psym(s)) + else + cg^.g_initialize_data(_list,Psym(s)); + end; + + procedure _finalize_data(s : pnamedindexobject);{$ifndef FPC}far;{$endif} + + begin + if typeof(s^)=typeof(Tvarsym) then + cg^.g_finalize_data(_list,s); + end; + + {$ELSE} procedure _finalize_data(s : pnamedindexobject);{$ifndef FPC}far;{$endif} begin @@ -589,12 +689,22 @@ unit cgobj; begin cg^.g_initialize_data(_list,psym(s)); end; + {$ENDIF NEWST} { generates the entry code for a procedure } procedure tcg.g_entrycode(list : paasmoutput;const proc_names:Tstringcontainer;make_global:boolean; stackframe:longint;var parasize:longint;var nostackframe:boolean; inlined : boolean); + + {$IFDEF NEWST} + procedure _copyvalueparas(s:Pparamsym);{$ifndef FPC}far;{$endif} + + begin + cg^.g_copyvalueparas(_list,s); + end; + {$ENDIF NEWST} + var hs : string; hp : pused_unit; @@ -617,7 +727,11 @@ unit cgobj; list^.insert(new(pai_align,init(4))); end; { save registers on cdecl } + {$IFDEF NEWST} + if (posavestdregs in aktprocdef^.options) then + {$ELSE} if (po_savestdregs in aktprocsym^.definition^.procoptions) then + {$ENDIF NEWST} begin for r:=firstreg to lastreg do begin @@ -639,21 +753,39 @@ unit cgobj; begin CGMessage(cg_d_stackframe_omited); nostackframe:=true; - if (aktprocsym^.definition^.proctypeoption in [potype_unitinit,potype_proginit,potype_unitfinalize]) then + {$IFDEF NEWST} + if (aktprocdef^.proctype in [potype_unitinit,potype_proginit,potype_unitfinalize]) then + parasize:=0 + else + parasize:=aktprocdef^.localst^.paramdatasize+procinfo^.para_offset-pointersize; + {$ELSE} + if (aktproc^.proctypeoption in [potype_unitinit,potype_proginit,potype_unitfinalize]) then parasize:=0 else parasize:=aktprocsym^.definition^.parast^.datasize+procinfo^.para_offset-pointersize; + {$ENDIF NEWST} end else begin - if (aktprocsym^.definition^.proctypeoption in [potype_unitinit,potype_proginit,potype_unitfinalize]) then + {$IFDEF NEWST} + if (aktprocdef^.proctype in [potype_unitinit,potype_proginit,potype_unitfinalize]) then + parasize:=0 + else + parasize:=aktprocdef^.localst^.paramdatasize+procinfo^.para_offset-pointersize*2; + {$ELSE} + if (aktprocdef^.proctypeoption in [potype_unitinit,potype_proginit,potype_unitfinalize]) then parasize:=0 else parasize:=aktprocsym^.definition^.parast^.datasize+procinfo^.para_offset-pointersize*2; + {$ENDIF} nostackframe:=false; - - if (po_interrupt in aktprocsym^.definition^.procoptions) then + {$IFDEF NEWST} + if (pointerrupt in aktprocdef^.options) then g_interrupt_stackframe_entry(list); + {$ELSE} + if (po_interrupt in aktprocdef^.procoptions) then + g_interrupt_stackframe_entry(list); + {$ENDIF NEWST} g_stackframe_entry(list,stackframe); @@ -664,7 +796,11 @@ unit cgobj; if cs_profile in aktmoduleswitches then g_profilecode(@initcode); + {$IFDEF NEWST} + if (not inlined) and (aktprocdef^.proctype in [potype_unitinit]) then + {$ELSE} if (not inlined) and (aktprocsym^.definition^.proctypeoption in [potype_unitinit]) then + {$ENDIF NEWST} begin { needs the target a console flags ? } @@ -715,6 +851,18 @@ unit cgobj; list^.insert(new(pai_force_line,init)); {$endif GDB} + {$IFDEF NEWST} + { initialize return value } + if assigned(procinfo^.retdef) and + is_ansistring(procinfo^.retdef) or + is_widestring(procinfo^.retdef) then + begin + reset_reference(hr); + hr.offset:=procinfo^.return_offset; + hr.base:=procinfo^.framepointer; + a_load_const_ref(list,OS_32,0,hr); + end; + {$ELSE} { initialize return value } if assigned(procinfo^.returntype.def) and is_ansistring(procinfo^.returntype.def) or @@ -725,21 +873,42 @@ unit cgobj; hr.base:=procinfo^.framepointer; a_load_const_ref(list,OS_32,0,hr); end; + {$ENDIF} _list:=list; { generate copies of call by value parameters } + {$IFDEF NEWST} + if (poassembler in aktprocdef^.options) then + aktprocdef^.parameters^.foreach(@_copyvalueparas); + {$ELSE} if (po_assembler in aktprocsym^.definition^.procoptions) then aktprocsym^.definition^.parast^.foreach({$ifdef FPC}@{$endif FPC}_copyvalueparas); + {$ENDIF NEWST} + {$IFDEF NEWST} + { initialisizes local data } + aktprocdef^.localst^.foreach({$ifdef FPC}@{$endif FPC}_initialize_local); + {$ELSE} { initialisizes local data } aktprocsym^.definition^.localst^.foreach({$ifdef FPC}@{$endif FPC}_initialize_data); { add a reference to all call by value/const parameters } aktprocsym^.definition^.parast^.foreach({$ifdef FPC}@{$endif FPC}_incr_data); + {$ENDIF NEWST} + {$IFDEF NEWST} + if (cs_profile in aktmoduleswitches) or + (typeof(aktprocdef^.owner^)=typeof(Tglobalsymtable)) or + (typeof(aktprocdef^.owner^)=typeof(Timplsymtable)) or + (assigned(procinfo^._class) and + (typeof(procinfo^._class^.owner^)=typeof(Tglobalsymtable)) or + (typeof(procinfo^._class^.owner^)=typeof(Timplsymtable))) then + make_global:=true; + {$ELSE} if (cs_profile in aktmoduleswitches) or (aktprocsym^.definition^.owner^.symtabletype=globalsymtable) or (assigned(procinfo^._class) and (procinfo^._class^.owner^.symtabletype=globalsymtable)) then make_global:=true; + {$ENDIF NEWST} if not inlined then begin hs:=proc_names.get; @@ -798,9 +967,17 @@ unit cgobj; list^.insert(new(pai_label,init(aktexitlabel))); { call the destructor help procedure } + {$IFDEF NEWST} + if (aktprocdef^.proctype=potype_destructor) then + {$ELSE} if (aktprocsym^.definition^.proctypeoption=potype_destructor) then + {$ENDIF} begin + {$IFDEF NEWST} + if oo_is_class in procinfo^._class^.options then + {$ELSE NEWST} if procinfo^._class^.is_class then + {$ENDIF} a_call_name(list,'FPC_DISPOSE_CLASS',0) else begin @@ -835,11 +1012,17 @@ unit cgobj; _list:=list; { finalize local data } + {$IFDEF NEWST} + aktprocdef^.localst^.foreach({$ifndef TP}@{$endif}_finalize_data); + {$ELSE} aktprocsym^.definition^.localst^.foreach({$ifndef TP}@{$endif}_finalize_data); + {$ENDIF} + {$IFNDEF NEWST} { finalize paras data } - if assigned(aktprocsym^.definition^.parast) then + if assigned(aktprocdef^.parast) then aktprocsym^.definition^.parast^.foreach({$ifndef TP}@{$endif}_finalize_data); + {$ENDIF NEWST} { do we need to handle exceptions because of ansi/widestrings ? } if (procinfo^.flags and pi_needs_implicit_finally)<>0 then @@ -852,6 +1035,19 @@ unit cgobj; a_cmp_reg_const_label(list,OS_32,OC_EQ,0,accumulator,noreraiselabel); a_reg_dealloc(list,accumulator); + {$IFDEF NEWST} + { must be the return value finalized before reraising the exception? } + if (procinfo^.retdef<>pdef(voiddef)) and + (procinfo^.retdef^.needs_inittable) and + ((typeof(procinfo^.retdef^)<>typeof(Tobjectdef)) or + not(oo_is_class in pobjectdef(procinfo^.retdef)^.options)) then + begin + reset_reference(hr); + hr.offset:=procinfo^.return_offset; + hr.base:=procinfo^.framepointer; + g_finalize(list,procinfo^.retdef,hr,not (dp_ret_in_acc in procinfo^.retdef^.properties)); + end; + {$ELSE} { must be the return value finalized before reraising the exception? } if (procinfo^.returntype.def<>pdef(voiddef)) and (procinfo^.returntype.def^.needs_inittable) and @@ -863,18 +1059,29 @@ unit cgobj; hr.base:=procinfo^.framepointer; g_finalize(list,procinfo^.returntype.def,hr,ret_in_param(procinfo^.returntype.def)); end; + {$ENDIF} a_call_name(list,'FPC_RERAISE',0); a_label(list,noreraiselabel); end; { call __EXIT for main program } + {$IFDEF NEWST} + if (not DLLsource) and (not inlined) and (aktprocdef^.proctype=potype_proginit) then + a_call_name(list,'FPC_DO_EXIT',0); + {$ELSE} if (not DLLsource) and (not inlined) and (aktprocsym^.definition^.proctypeoption=potype_proginit) then a_call_name(list,'FPC_DO_EXIT',0); + {$ENDIF NEWST} { handle return value } + {$IFDEF NEWST} + if not(poassembler in aktprocdef^.options) then + if (aktprocdef^.proctype<>potype_constructor) then + {$ELSE} if not(po_assembler in aktprocsym^.definition^.procoptions) then if (aktprocsym^.definition^.proctypeoption<>potype_constructor) then + {$ENDIF NEWST} { handle_return_value(inlined) } else begin @@ -918,11 +1125,19 @@ unit cgobj; { at last, the return is generated } if not inlined then + {$IFDEF NEWST} + if pointerrupt in aktprocdef^.options then + {$ELSE} if po_interrupt in aktprocsym^.definition^.procoptions then + {$ENDIF NEWST} g_interrupt_stackframe_exit(list) else g_return_from_proc(list,parasize); + {$IFDEF NEWST} + list^.concat(new(pai_symbol_end,initname(aktprocdef^.mangledname))); + {$ELSE NEWST} list^.concat(new(pai_symbol_end,initname(aktprocsym^.definition^.mangledname))); + {$ENDIF NEWST} {$ifdef GDB} if (cs_debuginfo in aktmoduleswitches) and not inlined then @@ -1114,7 +1329,12 @@ unit cgobj; end. { $Log$ - Revision 1.35 2000-03-01 15:36:13 florian + Revision 1.36 2000-03-11 21:11:24 daniel + * Ported hcgdata to new symtable. + * Alignment code changed as suggested by Peter + + Usage of my is operator replacement, is_object + + Revision 1.35 2000/03/01 15:36:13 florian * some new stuff for the new cg Revision 1.34 2000/02/20 20:49:46 florian diff --git a/compiler/new/symtable/cobjects.pas b/compiler/new/symtable/cobjects.pas index 0ab441386e..232ffb2128 100644 --- a/compiler/new/symtable/cobjects.pas +++ b/compiler/new/symtable/cobjects.pas @@ -33,12 +33,14 @@ unit cobjects; interface uses strings,objects +{$IFDEF TP} + ,xobjects +{$ENDIF} {$ifndef linux} - ,dos + ,dos {$else} - ,linux -{$endif} - ; + ,linux +{$endif}; const { the real size will be [-hasharray..hasharray] ! } @@ -75,6 +77,9 @@ type pfileposinfo = ^tfileposinfo; plinkedlist_item = ^tlinkedlist_item; tlinkedlist_item = object(Tobject) next,previous : plinkedlist_item; + {$IFDEF TP} + constructor init; + {$ENDIF TP} function getcopy:plinkedlist_item;virtual; end; @@ -90,6 +95,9 @@ type pfileposinfo = ^tfileposinfo; plinkedlist = ^tlinkedlist; tlinkedlist = object(Tobject) first,last : plinkedlist_item; + {$IFDEF TP} + constructor init; + {$ENDIF TP} destructor done;virtual; { disposes the items of the list } @@ -122,6 +130,9 @@ type pfileposinfo = ^tfileposinfo; PStringQueue=^TStringQueue; TStringQueue=object(Tobject) first,last : PStringItem; + {$IFDEF TP} + constructor init; + {$ENDIF TP} destructor Done;virtual; function Empty:boolean; function Get:string; @@ -189,7 +200,6 @@ type pfileposinfo = ^tfileposinfo; procedure usehash; procedure clear; function empty:boolean; - function contains(obj:Pnamedindexobject):boolean; procedure foreach(proc2call:Tnamedindexcallback); function insert(obj:Pnamedindexobject):Pnamedindexobject; function rename(const olds,news : string):Pnamedindexobject; @@ -535,6 +545,14 @@ end; TStringQueue ****************************************************************************} +{$IFDEF TP} +constructor Tstringqueue.init; + +begin + setparent(typeof(Tobject)); +end; +{$ENDIF TP} + function TStringQueue.Empty:boolean; begin Empty:=(first=nil); @@ -652,6 +670,7 @@ end; constructor tstringcontainer.init; begin inherited init; + {$IFDEF TP}setparent(typeof(Tobject));{$ENDIF} doubles:=true; end; @@ -659,6 +678,7 @@ end; constructor tstringcontainer.init_no_double; begin doubles:=false; + {$IFDEF TP}setparent(typeof(Tobject));{$ENDIF} end; @@ -799,6 +819,14 @@ end; ****************************************************************************} + {$IFDEF TP} + constructor Tlinkedlist_item.init; + + begin + setparent(typeof(Tobject)); + end; + {$ENDIF TP} + function tlinkedlist_item.getcopy:plinkedlist_item; var l : longint; @@ -818,6 +846,7 @@ end; constructor tstring_item.init(const s : string); begin inherited init; + {$IFDEF TP}setparent(typeof(Tobject));{$ENDIF} str:=stringdup(s); end; @@ -834,6 +863,14 @@ end; ****************************************************************************} + {$IFDEF TP} + constructor Tlinkedlist.init; + + begin + setparent(typeof(Tobject)); + end; + {$ENDIF TP} + destructor tlinkedlist.done; begin clear; @@ -1006,6 +1043,7 @@ end; constructor Tnamedindexobject.init(const n:string); begin inherited init; + {$IFDEF TP}setparent(typeof(Tobject));{$ENDIF} { index } indexnr:=-1; { dictionary } @@ -1034,6 +1072,7 @@ end; constructor Tdictionary.init; begin inherited init; + {$IFDEF TP}setparent(typeof(Tobject));{$ENDIF} replace_existing:=false; end; @@ -1450,6 +1489,7 @@ end; constructor tdynamicarray.init(Aelemlen,Agrow:longint); begin inherited init; + {$IFDEF TP}setparent(typeof(Tobject));{$ENDIF} elemlen:=Aelemlen; growcount:=Agrow; grow; @@ -1609,6 +1649,7 @@ end; begin inherited init; + {$IFDEF TP}setparent(typeof(Tobject));{$ENDIF} assign(f,filename); bufsize:=_bufsize; clear_crc; @@ -1930,7 +1971,12 @@ end; end. { $Log$ - Revision 1.2 2000-03-01 11:43:55 daniel + Revision 1.3 2000-03-11 21:11:24 daniel + * Ported hcgdata to new symtable. + * Alignment code changed as suggested by Peter + + Usage of my is operator replacement, is_object + + Revision 1.2 2000/03/01 11:43:55 daniel * Some more work on the new symtable. + Symtable stack unit 'symstack' added. diff --git a/compiler/new/symtable/defs.pas b/compiler/new/symtable/defs.pas index 696e4e7a8c..601d011d83 100644 --- a/compiler/new/symtable/defs.pas +++ b/compiler/new/symtable/defs.pas @@ -29,7 +29,8 @@ unit defs; interface -uses symtable,objects,cobjects,symtablt,globtype +uses symtable,objects,{$IFDEF TP}xobjects,{$ENDIF} + cobjects,symtablt,globtype {$ifdef i386} ,cpubase {$endif} @@ -47,7 +48,7 @@ type Targconvtyp=(act_convertable,act_equal,act_exact); Tobjprop=(sp_public,sp_private,sp_protected,sp_published,sp_static); Tobjpropset=set of Tobjprop; - Tobjoption=(oo_is_abstract, {The object/class has + Tobjoption=(oo_has_abstract, {The object/class has an abstract method => no instances can be created.} oo_is_class, {The object is a class.} @@ -64,6 +65,7 @@ type Targconvtyp=(act_convertable,act_equal,act_exact); constructor.} oo_has_destructor, {The object/class has a destructor.} + oo_has_vmt, {The object/class has a vmt.} oo_has_msgstr, oo_has_msgint, @@ -173,6 +175,9 @@ type Targconvtyp=(act_convertable,act_equal,act_exact); Perrordef=^Terrordef; Terrordef=object(Tdef) +{$IFDEF TP} + constructor init(Aowner:Pcontainingsymtable); +{$ENDIF} {$ifdef GDB} function stabstring:Pchar;virtual; {$endif GDB} @@ -204,6 +209,9 @@ type Targconvtyp=(act_convertable,act_equal,act_exact); Pclassrefdef=^Tclassrefdef; Tclassrefdef=object(Tpointerdef) +{$IFDEF TP} + constructor init(Aowner:Pcontainingsymtable;def:Pdef); +{$ENDIF TP} {$ifdef GDB} function stabstring : pchar;virtual; procedure concatstabto(asmlist : paasmoutput);virtual; @@ -465,29 +473,48 @@ type Targconvtyp=(act_convertable,act_equal,act_exact); function para_size:longint; procedure store(var s:Tstream);virtual; procedure test_if_fpu_result; - {$ifdef GDB} +{$ifdef GDB} function stabstring : pchar;virtual; procedure concatstabto(asmlist : paasmoutput);virtual; - {$endif GDB} +{$endif GDB} end; Pprocvardef=^Tprocvardef; Tprocvardef=object(Tabstractprocdef) +{$IFDEF TP} + constructor init(Aowner:Pcontainingsymtable); +{$ENDIF TP} function size:longint;virtual; - {$ifdef GDB} +{$ifdef GDB} function stabstring:Pchar;virtual; procedure concatstabto(asmlist:Paasmoutput); virtual; - {$endif GDB} +{$endif GDB} procedure write_child_rtti_data;virtual; function is_publishable:boolean;virtual; procedure write_rtti_data;virtual; function gettypename:string;virtual; end; + {This datastructure is used to store the message information + when a procedure is declared as: + ;message 'str'; + ;message int; + ;virtual int; + } + Tmessageinf=record + case integer of + 0:(str:Pchar); + 1:(i:longint); + end; + + {This object can be splitted into a Tprocdef, for normal procedures, + a Tmethoddef for methods, and a Tinlinedprocdef and a + Tinlinedmethoddef for inlined procedures.} Pprocdef = ^Tprocdef; Tprocdef = object(tabstractprocdef) objprop:Tobjpropset; extnumber:longint; + messageinf:Tmessageinf; { where is this function defined, needed here because there is only one symbol for all overloaded functions } fileinfo:Tfileposinfo; @@ -579,7 +606,7 @@ var cformaldef:Pformaldef; {Unique formal definition.} implementation -uses systems,symbols,verbose,globals,aasm,files; +uses systems,symbols,verbose,globals,aasm,files,strings; const {If you change one of the following contants, you have also to change the typinfo unit @@ -628,6 +655,7 @@ constructor Tfiledef.init(Aowner:Pcontainingsymtable;ft:Tfiletype;tas:Pdef); begin inherited init(Aowner); + {$IFDEF TP}setparent(typeof(Tdef));{$ENDIF} filetype:=ft; definition:=tas; setsize; @@ -700,6 +728,7 @@ constructor Tformaldef.init(Aowner:Pcontainingsymtable); begin inherited init(Aowner); + {$IFDEF TP}setparent(typeof(Tdef));{$ENDIF} savesize:=target_os.size_of_pointer; end; @@ -729,6 +758,15 @@ end; Terrordef ****************************************************************************} +{$IFDEF TP} +constructor Terrordef.init(Aowner:Pcontainingsymtable); + +begin + inherited init(Aowner); + setparent(typeof(Tdef)); +end; +{$ENDIF TP} + function Terrordef.gettypename:string; begin @@ -743,6 +781,7 @@ constructor Tabstractpointerdef.init(Aowner:Pcontainingsymtable;def:Pdef); begin inherited init(Aowner); + {$IFDEF TP}setparent(typeof(Tdef));{$ENDIF} include(properties,dp_ret_in_acc); definition:=def; savesize:=target_os.size_of_pointer; @@ -782,6 +821,7 @@ constructor Tpointerdef.initfar(Aowner:Pcontainingsymtable;def:Pdef); begin inherited init(Aowner,def); + {$IFDEF TP}setparent(typeof(Tabstractpointerdef));{$ENDIF} is_far:=true; end; @@ -809,6 +849,15 @@ end; Tclassrefdef ****************************************************************************} +{$IFDEF TP} +constructor Tclassrefdef.init(Aowner:Pcontainingsymtable;def:Pdef); + +begin + inherited init(Aowner,def); + setparent(typeof(Tpointerdef)); +end; +{$ENDIF TP} + function Tclassrefdef.gettypename:string; begin @@ -824,6 +873,7 @@ constructor Tobjectdef.init(const n:string;Aowner:Pcontainingsymtable; begin inherited init(Aowner); + {$IFDEF TP}setparent(typeof(Tdef));{$ENDIF} new(publicsyms,init); publicsyms^.name:=stringdup(n); publicsyms^.defowner:=@self; @@ -1301,6 +1351,7 @@ constructor Tarraydef.init(const l,h:Tconstant;rd:Pdef; begin inherited init(Aowner); + {$IFDEF TP}setparent(typeof(Tdef));{$ENDIF} lowrange:=l; highrange:=h; rangedef:=rd; @@ -1487,6 +1538,7 @@ constructor Tenumdef.init(Aowner:Pcontainingsymtable); begin inherited init(Aowner); + {$IFDEF TP}setparent(typeof(Tdef));{$ENDIF} include(properties,dp_ret_in_acc); new(symbols,init(8,8)); calcsavesize; @@ -1663,6 +1715,7 @@ constructor Torddef.init(t:Tbasetype;l,h:Tconstant; begin inherited init(Aowner); + {$IFDEF TP}setparent(typeof(Tdef));{$ENDIF} include(properties,dp_ret_in_acc); low:=l; high:=h; @@ -1805,6 +1858,7 @@ constructor Tfloatdef.init(t:Tfloattype;Aowner:Pcontainingsymtable); begin inherited init(Aowner); + {$IFDEF TP}setparent(typeof(Tdef));{$ENDIF} if t=f32bit then include(properties,dp_ret_in_acc); typ:=t; @@ -1891,6 +1945,7 @@ constructor Tsetdef.init(s:Pdef;high:longint;Aowner:Pcontainingsymtable); begin inherited init(Aowner); + {$IFDEF TP}setparent(typeof(Tdef));{$ENDIF} definition:=s; if high<32 then begin @@ -1987,6 +2042,7 @@ constructor Trecorddef.init(s:Precordsymtable;Aowner:Pcontainingsymtable); begin inherited init(Aowner); + {$IFDEF TP}setparent(typeof(Tdef));{$ENDIF} symtable:=s; savesize:=symtable^.datasize; end; @@ -2185,6 +2241,7 @@ constructor Tstringdef.shortinit(l:byte;Aowner:Pcontainingsymtable); begin inherited init(Aowner); + {$IFDEF TP}setparent(typeof(Tdef));{$ENDIF} string_typ:=st_shortstring; len:=l; savesize:=len+1; @@ -2413,6 +2470,7 @@ constructor Tabstractprocdef.init(Aowner:Pcontainingsymtable); begin inherited init(Aowner); + {$IFDEF TP}setparent(typeof(Tdef));{$ENDIF} include(properties,dp_ret_in_acc); retdef:=voiddef; savesize:=target_os.size_of_pointer; @@ -2525,6 +2583,7 @@ constructor Tprocdef.init(Aowner:Pcontainingsymtable); begin inherited init(Aowner); + {$IFDEF TP}setparent(typeof(Tabstractprocdef));{$ENDIF} fileinfo:=aktfilepos; extnumber:=-1; new(localst,init); @@ -2677,6 +2736,8 @@ end; destructor Tprocdef.done; begin + if pomsgstr in options then + strdispose(messageinf.str); if references<>nil then dispose(references,done); if (localst<>nil) and (typeof(localst^)<>typeof(Timplsymtable)) then @@ -2785,11 +2846,18 @@ begin end; end; - {*************************************************************************** Tprocvardef ***************************************************************************} +{$IFDEF TP} +constructor Tprocvardef.init(Aowner:Pcontainingsymtable); + +begin + setparent(typeof(Tabstractprocdef)); +end; +{$ENDIF TP} + function Tprocvardef.size:longint; @@ -2893,6 +2961,7 @@ begin { oldregisterdef:=registerdef; registerdef:=false;} inherited init(Aowner); + {$IFDEF TP}setparent(typeof(Tdef));{$ENDIF} { registerdef:=oldregisterdef;} tosymname:=s; forwardpos:=pos; @@ -2909,7 +2978,12 @@ end. { $Log$ - Revision 1.4 2000-03-01 11:43:55 daniel + Revision 1.5 2000-03-11 21:11:24 daniel + * Ported hcgdata to new symtable. + * Alignment code changed as suggested by Peter + + Usage of my is operator replacement, is_object + + Revision 1.4 2000/03/01 11:43:55 daniel * Some more work on the new symtable. + Symtable stack unit 'symstack' added. diff --git a/compiler/new/symtable/hcgdata.pas b/compiler/new/symtable/hcgdata.pas new file mode 100644 index 0000000000..844c404240 --- /dev/null +++ b/compiler/new/symtable/hcgdata.pas @@ -0,0 +1,651 @@ +{ + $Id$ + Copyright (c) 1998-2000 by Daniel Mantione, + and other members of the Free Pascal development team + + Routines for the code generation of data structures + like VMT,Messages + + 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 hcgdata; +interface + + uses + symtable,aasm,defs; + + { generates the message tables for a class } + function genstrmsgtab(_class : pobjectdef) : pasmlabel; + function genintmsgtab(_class : pobjectdef) : pasmlabel; + { generates the method name table } + function genpublishedmethodstable(Aclass:Pobjectdef):Pasmlabel; + + { generates a VMT for _class } + procedure genvmt(list : paasmoutput;_class : pobjectdef); + +{$ifdef WITHDMT} + { generates a DMT for _class } + function gendmt(_class : pobjectdef) : pasmlabel; +{$endif WITHDMT} + +implementation + + uses + strings,cobjects,globtype,globals,verbose, + types,hcodegen,symbols,objects,xobjects; + + +{***************************************************************************** + Message +*****************************************************************************} + + type + pprocdeftree = ^tprocdeftree; + tprocdeftree = record + p : pprocdef; + nl : pasmlabel; + l,r : pprocdeftree; + end; + + var + root : pprocdeftree; + count : longint; + + procedure insertstr(p : pprocdeftree;var at : pprocdeftree); + + var + i : longint; + + begin + if at=nil then + begin + at:=p; + inc(count); + end + else + begin + i:=strcomp(p^.p^.messageinf.str,at^.p^.messageinf.str); + if i<0 then + insertstr(p,at^.l) + else if i>0 then + insertstr(p,at^.r) + else + Message1(parser_e_duplicate_message_label,strpas(p^.p^.messageinf.str)); + end; + end; + + procedure disposeprocdeftree(p : pprocdeftree); + + begin + if assigned(p^.l) then + disposeprocdeftree(p^.l); + if assigned(p^.r) then + disposeprocdeftree(p^.r); + dispose(p); + end; + + procedure insertmsgstr(p:pnamedindexobject);{$ifndef FPC}far;{$endif FPC} + + procedure inserter(p:pointer);{$IFDEF TP}far;{$ENDIF} + + var pt:Pprocdeftree; + + begin + if pomsgstr in Pprocdef(p)^.options then + begin + new(pt); + pt^.p:=p; + pt^.l:=nil; + pt^.r:=nil; + insertstr(pt,root); + end; + end; + + begin + if typeof(p^)=typeof(Tprocsym) then + Pprocsym(p)^.foreach(@inserter); + end; + + procedure insertint(p : pprocdeftree;var at : pprocdeftree); + + begin + if at=nil then + begin + at:=p; + inc(count); + end + else + begin + if p^.p^.messageinf.iat^.p^.messageinf.i then + insertint(p,at^.r) + else + Message1(parser_e_duplicate_message_label,tostr(p^.p^.messageinf.i)); + end; + end; + + procedure insertmsgint(p:pnamedindexobject);{$ifndef FPC}far;{$endif FPC} + + procedure inserter(p:pointer);{$IFDEF TP}far;{$ENDIF} + + var pt:Pprocdeftree; + + begin + if pomsgint in Pprocdef(p)^.options then + begin + new(pt); + pt^.p:=p; + pt^.l:=nil; + pt^.r:=nil; + insertint(pt,root); + end; + end; + + begin + if typeof(p^)=typeof(Tprocsym) then + Pprocsym(p)^.foreach(@inserter); + end; + + procedure writenames(p : pprocdeftree); + + begin + getdatalabel(p^.nl); + if assigned(p^.l) then + writenames(p^.l); + datasegment^.concat(new(pai_label,init(p^.nl))); + datasegment^.concat(new(pai_const,init_8bit(strlen(p^.p^.messageinf.str)))); + datasegment^.concat(new(pai_string,init_pchar(p^.p^.messageinf.str))); + if assigned(p^.r) then + writenames(p^.r); + end; + + procedure writestrentry(p : pprocdeftree); + + begin + if assigned(p^.l) then + writestrentry(p^.l); + + { write name label } + datasegment^.concat(new(pai_const_symbol,init(p^.nl))); + datasegment^.concat(new(pai_const_symbol,initname(p^.p^.mangledname))); + + if assigned(p^.r) then + writestrentry(p^.r); + end; + + function genstrmsgtab(_class : pobjectdef) : pasmlabel; + + + var + r : pasmlabel; + + begin + root:=nil; + count:=0; + if _class^.privatesyms<>nil then + _class^.privatesyms^.foreach({$ifndef TP}@{$endif}insertmsgstr); + if _class^.privatesyms<>nil then + _class^.protectedsyms^.foreach({$ifndef TP}@{$endif}insertmsgstr); + if _class^.privatesyms<>nil then + _class^.publicsyms^.foreach({$ifndef TP}@{$endif}insertmsgstr); + + { write all names } + if assigned(root) then + writenames(root); + + { now start writing of the message string table } + getdatalabel(r); + datasegment^.concat(new(pai_label,init(r))); + genstrmsgtab:=r; + datasegment^.concat(new(pai_const,init_32bit(count))); + if assigned(root) then + begin + writestrentry(root); + disposeprocdeftree(root); + end; + end; + + + procedure writeintentry(p : pprocdeftree); + + begin + if assigned(p^.l) then + writeintentry(p^.l); + + { write name label } + datasegment^.concat(new(pai_const,init_32bit(p^.p^.messageinf.i))); + datasegment^.concat(new(pai_const_symbol,initname(p^.p^.mangledname))); + + if assigned(p^.r) then + writeintentry(p^.r); + end; + + function genintmsgtab(_class : pobjectdef) : pasmlabel; + + var + r : pasmlabel; + + begin + root:=nil; + count:=0; + if _class^.privatesyms<>nil then + _class^.privatesyms^.foreach({$ifndef TP}@{$endif}insertmsgint); + if _class^.privatesyms<>nil then + _class^.protectedsyms^.foreach({$ifndef TP}@{$endif}insertmsgint); + if _class^.privatesyms<>nil then + _class^.publicsyms^.foreach({$ifndef TP}@{$endif}insertmsgint); + + { now start writing of the message string table } + getdatalabel(r); + datasegment^.concat(new(pai_label,init(r))); + genintmsgtab:=r; + datasegment^.concat(new(pai_const,init_32bit(count))); + if assigned(root) then + begin + writeintentry(root); + disposeprocdeftree(root); + end; + end; + +{$ifdef WITHDMT} + + procedure insertdmtentry(p : pnamedindexobject);{$ifndef FPC}far;{$endif FPC} + + var + hp : pprocdef; + pt : pprocdeftree; + + begin + if psym(p)^.typ=procsym then + begin + hp:=pprocsym(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 writedmtindexentry(p : pprocdeftree); + + begin + if assigned(p^.l) then + writedmtindexentry(p^.l); + datasegment^.concat(new(pai_const,init_32bit(p^.p^.messageinf.i))); + if assigned(p^.r) then + writedmtindexentry(p^.r); + end; + + procedure writedmtaddressentry(p : pprocdeftree); + + begin + if assigned(p^.l) then + writedmtaddressentry(p^.l); + datasegment^.concat(new(pai_const_symbol,initname(p^.p^.mangledname))); + if assigned(p^.r) then + writedmtaddressentry(p^.r); + end; + + function gendmt(_class : pobjectdef) : pasmlabel; + + var + r : pasmlabel; + + begin + root:=nil; + count:=0; + gendmt:=nil; + { insert all message handlers into a tree, sorted by number } + _class^.symtable^.foreach({$ifndef TP}@{$endif}insertdmtentry); + + if count>0 then + begin + getdatalabel(r); + gendmt:=r; + datasegment^.concat(new(pai_label,init(r))); + { entries for caching } + datasegment^.concat(new(pai_const,init_32bit(0))); + datasegment^.concat(new(pai_const,init_32bit(0))); + + datasegment^.concat(new(pai_const,init_32bit(count))); + if assigned(root) then + begin + writedmtindexentry(root); + writedmtaddressentry(root); + disposeprocdeftree(root); + end; + end; + end; + +{$endif WITHDMT} + + procedure genpubmethodtableentry(p : pnamedindexobject);{$ifndef FPC}far;{$endif} + + procedure do_concat(q:pointer);{$ifndef FPC}far;{$endif} + + var l:Pasmlabel; + + begin + if (sp_published in Pprocdef(q)^.objprop) then + begin + getlabel(l); + + consts^.concat(new(pai_label,init(l))); + consts^.concat(new(pai_const,init_8bit(length(p^.name)))); + consts^.concat(new(pai_string,init(p^.name))); + + datasegment^.concat(new(pai_const_symbol,init(l))); + datasegment^.concat(new(pai_const_symbol,initname(Pprocdef(q)^.mangledname))); + end; + end; + + begin + if p^.is_object(typeof(Tprocsym)) then + Pprocsym(p)^.foreach(@do_concat); + end; + + procedure sym_do_count(p:Pnamedindexobject);{$ifndef FPC}far;{$endif} + + procedure def_do_count(p:pointer);{$ifndef FPC}far;{$endif} + + begin + if (sp_published in Pprocdef(p)^.objprop) then + inc(count); + end; + + begin + if Pobject(p)^.is_object(typeof(Tprocsym)) then + Pprocsym(p)^.foreach(@def_do_count); + end; + + function genpublishedmethodstable(Aclass:Pobjectdef):Pasmlabel; + + var l:Pasmlabel; + + begin + count:=0; + if Aclass^.privatesyms<>nil then + Aclass^.privatesyms^.foreach({$ifndef TP}@{$endif}sym_do_count); + if Aclass^.protectedsyms<>nil then + Aclass^.publicsyms^.foreach({$ifndef TP}@{$endif}sym_do_count); + if Aclass^.publicsyms<>nil then + Aclass^.publicsyms^.foreach({$ifndef TP}@{$endif}sym_do_count); + if count>0 then + begin + getlabel(l); + datasegment^.concat(new(pai_label,init(l))); + datasegment^.concat(new(pai_const,init_32bit(count))); + if Aclass^.privatesyms<>nil then + Aclass^.privatesyms^.foreach({$ifndef TP}@{$endif}genpubmethodtableentry); + if Aclass^.protectedsyms<>nil then + Aclass^.protectedsyms^.foreach({$ifndef TP}@{$endif}genpubmethodtableentry); + if Aclass^.publicsyms<>nil then + Aclass^.publicsyms^.foreach({$ifndef TP}@{$endif}genpubmethodtableentry); + genpublishedmethodstable:=l; + end + else + genpublishedmethodstable:=nil; + end; + +{***************************************************************************** + VMT +*****************************************************************************} + +var wurzel:Pcollection; + nextvirtnumber : longint; + _c : pobjectdef; + has_constructor,has_virtual_method : boolean; + +procedure eachsym(sym:Pnamedindexobject);{$ifndef FPC}far;{$endif FPC} + +var symcoll:Pcollection; + _name:string; + stored:boolean; + + {Creates a new entry in the procsym list.} + procedure newentry; + + procedure numbervirtual(p:pointer);{$IFDEF TP}far;{$ENDIF TP} + + begin + { if it's a virtual method } + if (povirtualmethod in Pprocdef(p)^.options) then + begin + {Then it gets a number ...} + Pprocdef(p)^.extnumber:=nextvirtnumber; + {And we inc the number } + inc(nextvirtnumber); + has_virtual_method:=true; + end; + + if (Pprocdef(p)^.proctype=potype_constructor) then + has_constructor:=true; + + { check, if a method should be overridden } + if (pooverridingmethod in Pprocdef(p)^.options) then + messagepos1(Pprocdef(p)^.fileinfo,parser_e_nothing_to_be_overridden, + _c^.objname^+'.'+_name+Pprocdef(p)^.demangled_paras); + end; + + begin + symcoll^.insert(sym); + Pprocsym(sym)^.foreach(@numbervirtual); + end; + + function match(p:pointer):boolean;{$IFDEF TP}far;{$ENDIF} + + begin + {Does the symbol already exist in the list ?} + match:=_name=Psym(p)^.name; + end; + + procedure eachdef(p:pointer);{$IFDEF TP}far;{$ENDIF} + + function check_override(q:pointer):boolean;{$IFDEF TP}far;{$ENDIF} + + begin + check_override:=false; + {Check if the parameters are equal and if one of the methods + is virtual.} + if equal_paras(Pprocdef(p)^.parameters, + Pprocdef(q)^.parameters,false) and + ((povirtualmethod in Pprocdef(p)^.options) or + (povirtualmethod in Pprocdef(q)^.options)) then + begin + {Wenn sie gleich sind + und eine davon virtual deklariert ist + Fehler falls nur eine VIRTUAL } + if (povirtualmethod in Pprocdef(p)^.options)<> + (povirtualmethod in Pprocdef(q)^.options) then + begin + { in classes, we hide the old method } + if oo_is_class in _c^.options then + begin + {Warn only if it is the first time, + we hide the method.} + if _c=Pprocsym(Pprocdef(p)^.sym)^._class then + message1(parser_w_should_use_override,_c^.objname^+'.'+_name); + newentry; + check_override:=true; + exit; + end + else + if _c=Pprocsym(Pprocdef(p)^.sym)^._class then + begin + if (povirtualmethod in Pprocdef(q)^.options) then + message1(parser_w_overloaded_are_not_both_virtual,_c^.objname^+'.'+_name) + else + message1(parser_w_overloaded_are_not_both_non_virtual, + _c^.objname^+'.'+_name); + newentry; + check_override:=true; + exit; + end; + end + else + {The flags have to match except abstract + and override, but only if both are virtual!!} + if (Pprocdef(q)^.calloptions<>Pprocdef(p)^.calloptions) or + (Pprocdef(q)^.proctype<>Pprocdef(p)^.proctype) or + ((Pprocdef(q)^.options-[poabstractmethod,pooverridingmethod,poassembler])<> + (Pprocdef(p)^.options-[poabstractmethod,pooverridingmethod,poassembler])) then + message1(parser_e_header_dont_match_forward,_c^.objname^+'.'+_name); + + {Check, if the override directive is set + (povirtualmethod is set!} + + {Class ?} + if (oo_is_class in _c^.options) and + not(pooverridingmethod in Pprocdef(p)^.options) then + begin + {Warn only if it is the first time, + we hide the method.} + if _c=Pprocsym(Pprocdef(p)^.sym)^._class then + message1(parser_w_should_use_override,_c^.objname^+'.'+_name); + newentry; + check_override:=true; + exit; + end; + + { error, if the return types aren't equal } + if not(is_equal(Pprocdef(q)^.retdef,Pprocdef(p)^.retdef)) and + not(Pprocdef(q)^.retdef^.is_object(typeof(Tobjectdef)) and + Pprocdef(p)^.retdef^.is_object(typeof(Tobjectdef)) and + (oo_is_class in Pobjectdef(Pprocdef(q)^.retdef)^.options) and + (oo_is_class in Pobjectdef(Pprocdef(p)^.retdef)^.options) and + (pobjectdef(Pprocdef(p)^.retdef)^.is_related( + pobjectdef(Pprocdef(q)^.retdef)))) then + message1(parser_e_overloaded_methodes_not_same_ret,_c^.objname^+'.'+_name); + + + {now set the number } + Pprocdef(p)^.extnumber:=Pprocdef(q)^.extnumber; + end; { same parameters } + end; + + begin + if Pprocsym(sym)^.firstthat(@check_override)=nil then + newentry; + end; + + +begin + {Put only subroutines into the VMT.} + if sym^.is_object(typeof(Tprocsym)) then + begin + symcoll:=wurzel; + Pprocsym(symcoll^.firstthat(@match))^.foreach(@eachdef); + newentry; + end; +end; + +procedure genvmt(list:Paasmoutput;_class:Pobjectdef); + +var symcoll:Pcollection; + i:longint; + + procedure do_genvmt(p:Pobjectdef); + + begin + {Start with the base class.} + if assigned(p^.childof) then + do_genvmt(p^.childof); + + { walk through all public syms } + { I had to change that to solve bug0260 (PM)} + _c:=p; + { Florian, please check if you agree (PM) } + p^.privatesyms^.foreach({$ifndef TP}@{$endif}eachsym); + p^.protectedsyms^.foreach({$ifndef TP}@{$endif}eachsym); + p^.publicsyms^.foreach({$ifndef TP}@{$endif}eachsym); + end; + + procedure symwritevmt(p:pointer);{$IFDEF TP}far;{$ENDIF} + + procedure defwritevmt(q:pointer);{$IFDEF TP}far;{$ENDIF} + + begin + { writes the addresses to the VMT } + { but only this which are declared as virtual } + if (Pprocdef(q)^.extnumber=i) and + (povirtualmethod in Pprocdef(q)^.options) then + begin + { if a method is abstract, then is also the } + { class abstract and it's not allow to } + { generates an instance } + if (poabstractmethod in Pprocdef(q)^.options) then + begin + include(_class^.options,oo_has_abstract); + list^.concat(new(pai_const_symbol,initname('FPC_ABSTRACTERROR'))); + end + else + begin + list^.concat(new(pai_const_symbol, + initname(Pprocdef(q)^.mangledname))); + end; + end; + end; + + begin + Pprocsym(p)^.foreach(@defwritevmt); + end; + +begin + new(wurzel,init(64,16)); + nextvirtnumber:=0; + + has_constructor:=false; + has_virtual_method:=false; + + { generates a tree of all used methods } + do_genvmt(_class); + + if has_virtual_method and not(has_constructor) then + message1(parser_w_virtual_without_constructor,_class^.objname^); + + + { generates the VMT } + + { walk trough all numbers for virtual methods and search } + { the method } + for i:=0 to nextvirtnumber-1 do + begin + symcoll:=wurzel; + symcoll^.foreach(@symwritevmt); + end; + dispose(symcoll,done); +end; + + +end. +{ + $Log$ + Revision 1.1 2000-03-11 21:11:25 daniel + * Ported hcgdata to new symtable. + * Alignment code changed as suggested by Peter + + Usage of my is operator replacement, is_object + +} diff --git a/compiler/new/symtable/htypechk.pas b/compiler/new/symtable/htypechk.pas index e45e6e1de5..e7fb8e5f3a 100644 --- a/compiler/new/symtable/htypechk.pas +++ b/compiler/new/symtable/htypechk.pas @@ -122,7 +122,7 @@ implementation { tp7 procvar def support, in tp7 a procvar is always called, if the procvar is passed explicit a addrn would be there } if (m_tp_procvar in aktmodeswitches) and - (typeof(def_from^)=typeof(Tprocvardef)) and + (def_from^.is_object(typeof(Tprocvardef))) and (fromtreetype=loadn) then begin def_from:=pprocvardef(def_from)^.retdef; @@ -131,9 +131,9 @@ implementation { we walk the wanted (def_to) types and check then the def_from types if there is a conversion possible } b:=0; - if typeof(def_to^)=typeof(Torddef) then + if def_to^.is_object(typeof(Torddef)) then begin - if typeof(def_from^)=typeof(Torddef) then + if def_from^.is_object(typeof(Torddef)) then begin doconv:=basedefconverts[basedeftbl[Tbasetype(porddef(def_from)^.typ)],basedeftbl[porddef(def_to)^.typ]]; b:=1; @@ -146,7 +146,7 @@ implementation (not is_boolean(def_to))) then b:=0; end - else if typeof(def_from^)=typeof(Torddef) then + else if def_from^.is_object(typeof(Tenumdef)) then begin { needed for char(enum) } if explicit then @@ -156,14 +156,14 @@ implementation end; end; end - else if typeof(def_to^)=typeof(Tstringdef) then + else if def_to^.is_object(typeof(Tstringdef)) then begin - if typeof(def_from^)=typeof(Tstringdef) then + if def_from^.is_object(typeof(Tstringdef)) then begin doconv:=tc_string_2_string; b:=1; end - else if typeof(def_from^)=typeof(Torddef) then + else if def_from^.is_object(typeof(Torddef)) then begin { char to string} if is_char(def_from) then @@ -172,7 +172,7 @@ implementation b:=1; end; end - else if typeof(def_from^)=typeof(Tarraydef) then + else if def_from^.is_object(typeof(Tarraydef)) then begin { array of char to string, the length check is done by the firstpass of this node } if is_chararray(def_from) then @@ -187,7 +187,7 @@ implementation b:=2; end; end - else if typeof(def_from^)=typeof(Tpointerdef) then + else if def_from^.is_object(typeof(Tpointerdef)) then begin { pchar can be assigned to short/ansistrings } if is_pchar(def_from) and not(m_tp in aktmodeswitches) then @@ -197,9 +197,9 @@ implementation end; end; end - else if typeof(def_to^)=typeof(Tfloatdef) then + else if def_to^.is_object(typeof(Tfloatdef)) then begin - if typeof(def_from^)=typeof(Torddef) then + if def_from^.is_object(typeof(Torddef)) then begin { ordinal to real } if is_integer(def_from) then begin @@ -210,7 +210,7 @@ implementation b:=1; end; end - else if typeof(def_from^)=typeof(Tfloatdef) then + else if def_from^.is_object(typeof(Tfloatdef)) then begin { 2 float types ? } if pfloatdef(def_from)^.typ=pfloatdef(def_to)^.typ then doconv:=tc_equal @@ -227,9 +227,9 @@ implementation b:=1; end; end - else if typeof(def_to^)=typeof(Tenumdef) then + else if def_to^.is_object(typeof(Tenumdef)) then begin - if typeof(def_from^)=typeof(Tenumdef) then + if def_from^.is_object(typeof(Tenumdef)) then begin if assigned(penumdef(def_from)^.basedef) then hd1:=penumdef(def_from)^.basedef @@ -243,7 +243,7 @@ implementation b:=1; end; end - else if typeof(def_to^)=typeof(Tarraydef) then + else if def_to^.is_object(typeof(Tarraydef)) then begin { open array is also compatible with a single element of its base type } if is_open_array(def_to) and @@ -254,7 +254,7 @@ implementation end else begin - if typeof(def_from^)=typeof(Tarraydef) then + if def_from^.is_object(typeof(Tarraydef)) then begin { array constructor -> open array } if is_open_array(def_to) and @@ -275,7 +275,7 @@ implementation end; end; end - else if typeof(def_from^)=typeof(Tpointerdef) then + else if def_from^.is_object(typeof(Tpointerdef)) then begin if is_zero_based_array(def_to) and is_equal(ppointerdef(def_from)^.definition,parraydef(def_to)^.definition) then @@ -284,7 +284,7 @@ implementation b:=1; end; end - else if typeof(def_from^)=typeof(Tstringdef) then + else if def_from^.is_object(typeof(Tstringdef)) then begin { string to array of char} if (not(is_special_array(def_to)) or is_open_array(def_to)) and @@ -296,9 +296,9 @@ implementation end; end; end - else if typeof(def_to^)=typeof(Tpointerdef) then + else if def_to^.is_object(typeof(Tpointerdef)) then begin - if typeof(def_from^)=typeof(Tstringdef) then + if def_from^.is_object(typeof(Tstringdef)) then begin { string constant to zero terminated string constant } if (fromtreetype=stringconstn) and @@ -308,7 +308,7 @@ implementation b:=1; end; end - else if typeof(def_from^)=typeof(Torddef) then + else if def_from^.is_object(typeof(Torddef)) then begin { char constant to zero terminated string constant } if (fromtreetype=ordconstn) then @@ -327,7 +327,7 @@ implementation end; end; end - else if typeof(def_from^)=typeof(Tarraydef) then + else if def_from^.is_object(typeof(Tarraydef)) then begin { chararray to pointer } if is_zero_based_array(def_from) and @@ -337,13 +337,12 @@ implementation b:=1; end; end - else if typeof(def_from^)=typeof(Tpointerdef) then + else if def_from^.is_object(typeof(Tpointerdef)) then begin { child class pointer can be assigned to anchestor pointers } if ( - {Bug in TP: typeof(( )) required when typecasting.} - (typeof((Ppointerdef(def_from)^.definition^))=typeof(Tobjectdef)) and - (typeof((Ppointerdef(def_to)^.definition^))=typeof(Tobjectdef)) and + (Ppointerdef(def_from)^.definition^.is_object(typeof(Tobjectdef))) and + (Ppointerdef(def_to)^.definition^.is_object(typeof(Tobjectdef))) and pobjectdef(ppointerdef(def_from)^.definition)^.is_related( pobjectdef(ppointerdef(def_to)^.definition)) ) or @@ -357,7 +356,7 @@ implementation b:=1; end; end - else if typeof(def_from^)=typeof(Tprocvardef) then + else if def_from^.is_object(typeof(Tprocvardef)) then begin { procedure variable can be assigned to an void pointer } { Not anymore. Use the @ operator now.} @@ -369,17 +368,17 @@ implementation b:=1; end; end - else if (typeof(def_from^)=typeof(Tclassrefdef)) or - (typeof(def_from^)=typeof(Tobjectdef)) then + else if def_from^.is_object(typeof(Tclassrefdef)) or + def_from^.is_object(typeof(Tobjectdef)) then begin { class types and class reference type can be assigned to void pointers } if ( - ((typeof(def_from^)=typeof(Tobjectdef)) and - (oo_is_class in pobjectdef(def_from)^.options)) or - (typeof(def_from^)=typeof(Tclassrefdef)) + (def_from^.is_object(typeof(Tobjectdef)) and + (oo_is_class in pobjectdef(def_from)^.options))) or + (def_from^.is_object(typeof(Tclassrefdef)) ) and - (typeof((ppointerdef(def_to)^.definition^))=typeof(Torddef)) and + ppointerdef(def_to)^.definition^.is_object(typeof(Torddef)) and (porddef(ppointerdef(def_to)^.definition)^.typ=uvoid) then begin doconv:=tc_equal; @@ -387,7 +386,7 @@ implementation end; end; end - else if typeof(def_to^)=typeof(Tsetdef) then + else if def_to^.is_object(typeof(Tsetdef)) then begin { automatic arrayconstructor -> set conversion } if is_array_constructor(def_from) then @@ -396,10 +395,10 @@ implementation b:=1; end; end - else if typeof(def_to^)=typeof(Tprocvardef) then + else if def_to^.is_object(typeof(Tprocvardef)) then begin { proc -> procvar } - if (typeof(def_from^)=typeof(Tprocdef)) then + if def_from^.is_object(typeof(Tprocdef)) then begin doconv:=tc_proc_2_procvar; if proc_to_procvar_equal(pprocdef(def_from),pprocvardef(def_to)) then @@ -409,8 +408,8 @@ implementation { for example delphi allows the assignement from pointers } { to procedure variables } if (m_pointer_2_procedure in aktmodeswitches) and - (typeof(def_from^)=typeof(Tpointerdef)) and - (typeof((ppointerdef(def_from)^.definition^))=typeof(Torddef)) and + def_from^.is_object(typeof(Tpointerdef)) and + ppointerdef(def_from)^.definition^.is_object(typeof(Torddef)) and (porddef(ppointerdef(def_from)^.definition)^.typ=uvoid) then begin doconv:=tc_equal; @@ -424,10 +423,10 @@ implementation b:=1; end; end - else if typeof(def_to^)=typeof(Tobjectdef) then + else if def_to^.is_object(typeof(Tobjectdef)) then begin { object pascal objects } - if typeof(def_from^)=typeof(Tobjectdef) then + if def_from^.is_object(typeof(Tobjectdef)) then begin doconv:=tc_equal; if pobjectdef(def_from)^.is_related(pobjectdef(def_to)) then @@ -453,10 +452,10 @@ implementation end; end; end - else if typeof(def_to^)=typeof(Tclassrefdef) then + else if def_to^.is_object(typeof(Tclassrefdef)) then begin { class reference types } - if typeof(def_from^)=typeof(Tclassrefdef) then + if def_from^.is_object(typeof(Tclassrefdef)) then begin doconv:=tc_equal; if pobjectdef(pclassrefdef(def_from)^.definition)^.is_related( @@ -471,7 +470,7 @@ implementation b:=1; end; end - else if typeof(def_to^)=typeof(Tfiledef) then + else if def_to^.is_object(typeof(Tfiledef)) then begin { typed files are all equal to the abstract file type name TYPEDFILE in system.pp in is_equal in types.pas @@ -886,7 +885,12 @@ implementation end. { $Log$ - Revision 1.1 2000-02-28 17:23:58 daniel + Revision 1.2 2000-03-11 21:11:25 daniel + * Ported hcgdata to new symtable. + * Alignment code changed as suggested by Peter + + Usage of my is operator replacement, is_object + + Revision 1.1 2000/02/28 17:23:58 daniel * Current work of symtable integration committed. The symtable can be activated by defining 'newst', but doesn't compile yet. Changes in type checking and oop are completed. What is left is to write a new diff --git a/compiler/new/symtable/symbols.pas b/compiler/new/symtable/symbols.pas index 413e53c470..85ee745d23 100644 --- a/compiler/new/symtable/symbols.pas +++ b/compiler/new/symtable/symbols.pas @@ -90,6 +90,7 @@ type Ttypeprop=(sp_primary_typesym); _class:Pobjectdef; constructor init(const n:string;Asub_of:Pprocsym); constructor load(var s:Tstream); + function count:word; function firstthat(action:pointer):Pprocdef; procedure foreach(action:pointer); procedure insert(def:Pdef); @@ -244,7 +245,7 @@ type Ttypeprop=(sp_primary_typesym); Pfuncretsym=^Tfuncretsym; Tfuncretsym=object(tsym) - funcretprocinfo : pointer{ should be pprocinfo}; + funcretprocinfo:pointer{Pprocinfo}; funcretdef:Pdef; address:longint; constructor init(const n:string;approcinfo:pointer{pprocinfo}); @@ -307,6 +308,7 @@ constructor Tlabelsym.init(const n:string;l:Pasmlabel); begin inherited init(n); + {$IFDEF TP}setparent(typeof(Tsym));{$ENDIF} lab:=l; defined:=false; end; @@ -339,6 +341,7 @@ constructor terrorsym.init; begin inherited init(''); + {$IFDEF TP}setparent(typeof(Tsym));{$ENDIF} end; {**************************************************************************** Tprocsym @@ -348,6 +351,7 @@ constructor Tprocsym.init(const n:string;Asub_of:Pprocsym); begin inherited init(n); + {$IFDEF TP}setparent(typeof(Tsym));{$ENDIF} sub_of:=Asub_of; end; @@ -358,6 +362,15 @@ begin { definition:=Pprocdef(readdefref);} end; +function Tprocsym.count:word; + +begin + if typeof(definitions^)=typeof(Tcollection) then + count:=Pcollection(definitions)^.count + else + count:=1; +end; + function Tprocsym.firstthat(action:pointer):Pprocdef; begin @@ -522,6 +535,7 @@ constructor Ttypesym.init(const n:string;d:Pdef); begin inherited init(n); + {$IFDEF TP}setparent(typeof(Tsym));{$ENDIF} definition:=d; if assigned(definition) then begin @@ -679,6 +693,7 @@ constructor Tsyssym.init(const n:string;l:longint); begin inherited init(n); + {$IFDEF TP}setparent(typeof(Tsym));{$ENDIF} number:=l; end; @@ -704,6 +719,7 @@ constructor Tenumsym.init(const n:string;def:Penumdef;v:longint); begin inherited init(n); + {$IFDEF TP}setparent(typeof(Tsym));{$ENDIF} definition:=def; value:=v; if def^.minval>v then @@ -796,6 +812,7 @@ constructor Tvarsym.init(const n:string;p:Pdef); begin inherited init(n); + {$IFDEF TP}setparent(typeof(Tsym));{$ENDIF} definition:=p; {Can we load the value into a register ? } if dp_regable in p^.properties then @@ -937,6 +954,7 @@ constructor Tparamsym.init(const n:string;p:Pdef;vs:Tvarspez); begin inherited init(n,p); + {$IFDEF TP}setparent(typeof(Tsym));{$ENDIF} varspez:=vs; end; @@ -1004,6 +1022,7 @@ constructor Ttypedconstsym.init(const n:string;p:Pdef;really_const:boolean); begin inherited init(n); + {$IFDEF TP}setparent(typeof(Tsym));{$ENDIF} definition:=p; is_really_const:=really_const; prefix:=stringdup(procprefix); @@ -1085,6 +1104,7 @@ constructor Tconstsym.init(const n : string;t : tconsttype;v : longint); begin inherited init(n); + {$IFDEF TP}setparent(typeof(Tsym));{$ENDIF} consttype:=t; value:=v; end; @@ -1301,6 +1321,7 @@ constructor Tfuncretsym.init(const n:string;approcinfo:pointer{pprocinfo}); begin inherited init(n); + {$IFDEF TP}setparent(typeof(Tsym));{$ENDIF} funcretprocinfo:=approcinfo; { funcretdef:=Pprocinfo(approcinfo)^.retdef;} { address valid for ret in param only } @@ -1352,6 +1373,10 @@ begin end;} end; +{**************************************************************************** + Tpropertysym +****************************************************************************} + constructor tpropertysym.load(var s:Tstream); begin @@ -1448,7 +1473,12 @@ end. { $Log$ - Revision 1.4 2000-03-01 11:43:56 daniel + Revision 1.5 2000-03-11 21:11:25 daniel + * Ported hcgdata to new symtable. + * Alignment code changed as suggested by Peter + + Usage of my is operator replacement, is_object + + Revision 1.4 2000/03/01 11:43:56 daniel * Some more work on the new symtable. + Symtable stack unit 'symstack' added. diff --git a/compiler/new/symtable/symtable.pas b/compiler/new/symtable/symtable.pas index 5616797972..c49bcd2dc0 100644 --- a/compiler/new/symtable/symtable.pas +++ b/compiler/new/symtable/symtable.pas @@ -27,7 +27,8 @@ unit symtable; interface -uses objects,cobjects,aasm,globtype,cpubase; +uses objects{$IFDEF TP},xobjects{$ENDIF} + ,cobjects,aasm,globtype,cpubase; type Tdefprop=(dp_regable, {Can be stored into a register.} @@ -49,6 +50,9 @@ type Tdefprop=(dp_regable, {Can be stored into a register.} Tsymtable=object(Tobject) name:Pstring; datasize:longint; + {$IFDEF TP} + constructor init; + {$ENDIF TP} procedure foreach(proc2call:Tnamedindexcallback);virtual; function insert(sym:Psym):boolean;virtual; function search(const s:stringid):Psym; @@ -93,6 +97,9 @@ type Tdefprop=(dp_regable, {Can be stored into a register.} Tsymtableentry=object(Tnamedindexobject) owner:Pcontainingsymtable; + {$IFDEF TP} + constructor init(const n:string); + {$ENDIF TP} end; Tsymprop=byte; @@ -188,6 +195,13 @@ uses symtablt,files,verbose,globals; Tsymtable ****************************************************************************} +{$IFDEF TP} +constructor Tsymtable.init; + +begin + setparent(typeof(Tobject)); +end; +{$ENDIF TP} procedure Tsymtable.foreach(proc2call:Tnamedindexcallback); @@ -242,6 +256,8 @@ constructor Tcontainingsymtable.init; var indexgrow:word; begin + inherited init; + {$IFDEF TP}setparent(typeof(Tsymtable));{$ENDIF} indexgrow:=index_growsize; new(defindex,init(2*indexgrow,indexgrow)); new(symsearch,init); @@ -350,6 +366,7 @@ constructor Tref.init(const pos:Tfileposinfo); begin inherited init; + {$IFDEF TP}setparent(typeof(Tobject));{$ENDIF} posinfo:=pos; moduleindex:=current_module^.unit_index; end; @@ -373,6 +390,19 @@ begin current_module^.sourcefiles^.get_file_name(fileindex),tostr(line)); end; +{**************************************************************************** + Tsymtableentry +****************************************************************************} + +{$IFDEF TP} +constructor Tsymtableentry.init(const n:string); + +begin + inherited init(n); + setparent(typeof(Tnamedindexobject)); +end; +{$ENDIF TP} + {**************************************************************************** Tsym ****************************************************************************} @@ -381,6 +411,7 @@ constructor Tsym.init(const n:string); begin inherited init(n); + {$IFDEF TP}setparent(typeof(Tsymtableentry));{$ENDIF} fileinfo:=tokenpos; if cs_browser in aktmoduleswitches then new(references,init(32,16)); @@ -454,6 +485,7 @@ constructor Tdef.init(Aowner:Pcontainingsymtable); begin inherited init; + {$IFDEF TP}setparent(typeof(Tobject));{$ENDIF} Aowner^.registerdef(@self); owner:=Aowner; end; diff --git a/compiler/new/symtable/symtablt.pas b/compiler/new/symtable/symtablt.pas index 16e892aecd..b37cb85a48 100644 --- a/compiler/new/symtable/symtablt.pas +++ b/compiler/new/symtable/symtablt.pas @@ -50,24 +50,39 @@ type Pglobalsymtable=^Tglobalsymtable; Tinterfacesymtable=object(Tglobalsymtable) unitid:word; + {$IFDEF TP} + constructor init; + {$ENDIF TP} function varsymprefix:string;virtual; end; Timplsymtable=object(Tglobalsymtable) unitid:word; + {$IFDEF TP} + constructor init; + {$ENDIF TP} function varsymprefix:string;virtual; end; Tabstractrecordsymtable=object(Tcontainingsymtable) + {$IFDEF TP} + constructor init; + {$ENDIF TP} function varsymtodata(sym:Psym;len:longint):longint;virtual; end; Precordsymtable=^Trecordsymtable; Trecordsymtable=object(Tabstractrecordsymtable) + {$IFDEF TP} + constructor init; + {$ENDIF TP} end; Tobjectsymtable=object(Tabstractrecordsymtable) defowner:Pobjectsymtable; + {$IFDEF TP} + constructor init; + {$ENDIF TP} { function speedsearch(const s:stringid; speedvalue:longint):Psym;virtual;} end; @@ -80,6 +95,9 @@ type Pglobalsymtable=^Tglobalsymtable; possible to make another Tmethodsymtable and move this field to it, but I think the advantage is not worth it. (DM)} method:Pdef; + {$IFDEF TP} + constructor init; + {$ENDIF TP} function insert(sym:Psym):boolean;virtual; function speedsearch(const s:stringid; speedvalue:longint):Psym;virtual; @@ -113,17 +131,6 @@ implementation uses symbols,files,globals,aasm,systems,defs,verbose; -function data_align(length:longint):longint; - -begin - if length>2 then - data_align:=4 - else if length>1 then - data_align:=2 - else - data_align:=1; -end; - {**************************************************************************** Tglobalsymtable ****************************************************************************} @@ -132,6 +139,7 @@ constructor Tglobalsymtable.init; begin inherited init; + {$IFDEF TP}setparent(typeof(Tcontainingsymtable));{$ENDIF} index_growsize:=128; end; @@ -152,8 +160,7 @@ begin segment:=datasegment; if (cs_create_smart in aktmoduleswitches) then segment^.concat(new(Pai_cut,init)); - ali:=data_align(len); - align(datasize,ali); + align_from_size(datasize,len); {$ifdef GDB} if cs_debuginfo in aktmoduleswitches then concatstabto(segment); @@ -168,8 +175,7 @@ var ali:longint; begin if (cs_create_smart in aktmoduleswitches) then bsssegment^.concat(new(Pai_cut,init)); - ali:=data_align(len); - align(datasize,ali); + align_from_size(datasize,len); {$ifdef GDB} if cs_debuginfo in aktmoduleswitches then concatstabto(bsssegment); @@ -185,6 +191,14 @@ end; Timplsymtable ****************************************************************************} +{$IFDEF TP} +constructor Timplsymtable.init; + +begin + inherited init; + setparent(typeof(Tglobalsymtable)); +end; +{$ENDIF TP} function Timplsymtable.varsymprefix:string; @@ -196,6 +210,15 @@ end; Tinterfacesymtable ****************************************************************************} +{$IFDEF TP} +constructor Tinterfacesymtable.init; + +begin + inherited init; + setparent(typeof(Tglobalsymtable)); +end; +{$ENDIF TP} + function Tinterfacesymtable.varsymprefix:string; begin @@ -206,6 +229,15 @@ end; Tabstractrecordsymtable ****************************************************************************} +{$IFDEF TP} +constructor Tabstractrecordsymtable.init; + +begin + inherited init; + setparent(typeof(Tcontainingsymtable)); +end; +{$ENDIF TP} + function Tabstractrecordsymtable.varsymtodata(sym:Psym; len:longint):longint; @@ -219,10 +251,28 @@ end; Trecordsymtable ****************************************************************************} +{$IFDEF TP} +constructor Trecordsymtable.init; + +begin + inherited init; + setparent(typeof(Tabstractrecordsymtable)); +end; +{$ENDIF TP} + {**************************************************************************** Tobjectsymtable ****************************************************************************} +{$IFDEF TP} +constructor Tobjectsymtable.init; + +begin + inherited init; + setparent(typeof(Tabstractrecordsymtable)); +end; +{$ENDIF TP} + {This is not going to work this way, because the definition isn't known yet when the symbol hasn't been found. For procsyms the object properties are stored in the definitions, because they can be overloaded. @@ -247,6 +297,14 @@ end;} {**************************************************************************** Tprocsymsymtable ****************************************************************************} +{$IFDEF TP} +constructor Tprocsymtable.init; + +begin + inherited init; + setparent(typeof(Tcontainingsymtable)); +end; +{$ENDIF TP} function Tprocsymtable.insert(sym:Psym):boolean; @@ -279,17 +337,7 @@ begin begin {Sym must be a varsym.} {Align datastructures >=4 on a dword.} - if len>=4 then - align(len,4) - else -{$ifdef m68k} - {Align datastructures with size 1,2,3 on a word.} - align(len,2); -{$else} - {Align datastructures with size 2 or 3 on a word.} - if len>=2 then - align(len,2); -{$endif} + align_from_size(len,len); varsymtodata:=inherited varsymtodata(sym,len); end; end; @@ -302,6 +350,7 @@ constructor Tunitsymtable.init(const n:string); begin inherited init; + {$IFDEF TP}setparent(typeof(Tcontainingsymtable));{$ENDIF} name:=stringdup(n); index_growsize:=128; end; @@ -338,8 +387,7 @@ begin segment:=datasegment; if (cs_create_smart in aktmoduleswitches) then segment^.concat(new(Pai_cut,init)); - ali:=data_align(len); - align(datasize,ali); + align_from_size(datasize,len); {$ifdef GDB} if cs_debuginfo in aktmoduleswitches then concatstabto(segment); @@ -373,6 +421,7 @@ constructor Twithsymtable.init(Alink:Pcontainingsymtable); begin inherited init; + {$IFDEF TP}setparent(typeof(Tsymtable));{$ENDIF} link:=Alink; end; diff --git a/compiler/new/symtable/xobjects.pas b/compiler/new/symtable/xobjects.pas new file mode 100644 index 0000000000..33d59842ee --- /dev/null +++ b/compiler/new/symtable/xobjects.pas @@ -0,0 +1,81 @@ +unit xobjects; +{ + $Id$ + Copyright (c) 2000 by Daniel Mantione + member of the Free Pascal development team + + This unit provides an extends the Tobject type with additional methods + to check the type of an object. It should only be used within + Turbo Pascal, the Free Pascal objects unit already contains this + functionality. + + 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. + + **************************************************************************** +} +interface + +{As TP does not store a link to the parent's VMT in the VMT, a function like + is_object would be impossible. + + We use a very dirty trick to get it done; in an objects constructor the + setparent procedure should be called, which stores the link to the parent + into the DMT link. (!!!)} + +uses objects; + +type Pobject=^Tobject; + Tobject=object(objects.Tobject) + function is_object(typ:pointer):boolean; + procedure setparent(typ:pointer); + end; + +implementation + +type vmt=record + size,negsize:word; + dmtlink:pointer; + end; + +function Tobject.is_object(typ:pointer):boolean;assembler; + +asm + les di,self + mov bx,[es:di] {Get vmt link.} + jmp @a3 +@a2: + mov bx,[bx+4] {Get dmt link, offset.} + or bx,bx + mov al,0 + jz @a1 +@a3: + cmp bx,typ.word {Compare with typ.} + jne @a2 + mov al,1 +@a1: +end; + +procedure Tobject.setparent(typ:pointer);assembler; + +asm + les di,self + mov bx,[es:di] {Get vmt link.} + mov ax,typ.word + mov cx,typ+2.word + mov [bx+4],ax + mov [bx+6],cx +end; + +end. \ No newline at end of file diff --git a/compiler/pbase.pas b/compiler/pbase.pas index a85baf7dd6..a74849d0a4 100644 --- a/compiler/pbase.pas +++ b/compiler/pbase.pas @@ -29,6 +29,9 @@ unit pbase; {$ifdef fixLeaksOnError} ,comphook {$endif fixLeaksOnError} +{$IFDEF NEWST} + ,symbols,defs +{$ENDIF NEWST} ; const @@ -194,7 +197,12 @@ end. { $Log$ - Revision 1.30 2000-02-09 13:22:56 peter + Revision 1.31 2000-03-11 21:11:24 daniel + * Ported hcgdata to new symtable. + * Alignment code changed as suggested by Peter + + Usage of my is operator replacement, is_object + + Revision 1.30 2000/02/09 13:22:56 peter * log truncated Revision 1.29 2000/01/11 17:16:04 jonas diff --git a/compiler/ptype.pas b/compiler/ptype.pas index 7ae54fda40..c874869859 100644 --- a/compiler/ptype.pas +++ b/compiler/ptype.pas @@ -24,7 +24,10 @@ unit ptype; interface uses - globtype,symtable; + globtype,symtable + {$IFDEF NEWST} + ,symbols,defs + {$ENDIF NEWST}; const @@ -45,10 +48,16 @@ uses { reads a string, file type or a type id and returns a name and } - { pdef } + { pdef } +{$IFDEF NEWST} + procedure single_type(var tt:Tdef;var s : string;isforwarddef:boolean); + + procedure read_type(var tt:Tdef;const name : stringid); +{$ELSE} procedure single_type(var tt:ttype;var s : string;isforwarddef:boolean); procedure read_type(var tt:ttype;const name : stringid); +{$ENDIF NEWST} implementation @@ -1539,7 +1548,12 @@ uses end. { $Log$ - Revision 1.20 2000-02-24 18:41:39 peter + Revision 1.21 2000-03-11 21:11:24 daniel + * Ported hcgdata to new symtable. + * Alignment code changed as suggested by Peter + + Usage of my is operator replacement, is_object + + Revision 1.20 2000/02/24 18:41:39 peter * removed warnings/notes Revision 1.19 2000/02/21 22:17:49 florian