paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-16 04:59:25 +02:00
Code Issues Packages Projects Releases Wiki Activity

* Ported hcgdata to new symtable.

Browse Source 
* Alignment code changed as suggested by Peter
  + Usage of my is operator replacement, is_object
This commit is contained in:
daniel 2000-03-11 21:11:24 +00:00
parent 0cd558d9dd
commit 59cfa402c9
12 changed files with 1320 additions and 104 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
compiler/new/cgbase.pas
View File

@ -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

236
compiler/new/cgobj.pas
View File

@ -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

58
compiler/new/symtable/cobjects.pas
View File

@ -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.

92
compiler/new/symtable/defs.pas
View File

@ -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.

651
compiler/new/symtable/hcgdata.pas Normal file
View File

@ -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.i<at^.p^.messageinf.i then
insertint(p,at^.l)
else if p^.p^.messageinf.i>at^.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
}

92
compiler/new/symtable/htypechk.pas
View File

@ -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

34
compiler/new/symtable/symbols.pas
View File

@ -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.

34
compiler/new/symtable/symtable.pas
View File

@ -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;

105
compiler/new/symtable/symtablt.pas
View File

@ -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;

81
compiler/new/symtable/xobjects.pas Normal file
View File

@ -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.

10
compiler/pbase.pas
View File

@ -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

20
compiler/ptype.pas
View File

@ -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