mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-11-03 06:49:26 +01:00
+ fieldtable support for classes
This commit is contained in:
florian
parent
9a4a837f04
commit
2658c0aeda
@ -721,7 +721,8 @@ uses
|
||||
oldprocsym : pprocsym;
|
||||
oldparse_only : boolean;
|
||||
methodnametable,intmessagetable,
|
||||
strmessagetable,classnamelabel : pasmlabel;
|
||||
strmessagetable,classnamelabel,
|
||||
fieldtablelabel : pasmlabel;
|
||||
storetypecanbeforward : boolean;
|
||||
|
||||
procedure setclassattributes;
|
||||
@ -804,6 +805,7 @@ uses
|
||||
if is_a_class then
|
||||
begin
|
||||
methodnametable:=genpublishedmethodstable(aktclass);
|
||||
fieldtablelabel:=aktclass^.generate_field_table;
|
||||
{ rtti }
|
||||
if (oo_can_have_published in aktclass^.objectoptions) then
|
||||
aktclass^.generate_rtti;
|
||||
@ -872,7 +874,7 @@ uses
|
||||
else
|
||||
datasegment^.concat(new(pai_const,init_32bit(0)));
|
||||
{ pointer to field table }
|
||||
datasegment^.concat(new(pai_const,init_32bit(0)));
|
||||
datasegment^.concat(new(pai_const_symbol,init(fieldtablelabel)));
|
||||
{ pointer to type info of published section }
|
||||
if (oo_can_have_published in aktclass^.objectoptions) then
|
||||
datasegment^.concat(new(pai_const_symbol,initname(aktclass^.rtti_name)))
|
||||
@ -1592,7 +1594,10 @@ uses
|
||||
end.
|
||||
{
|
||||
$Log$
|
||||
Revision 1.24 2000-03-27 21:51:19 pierre
|
||||
Revision 1.25 2000-06-02 18:48:47 florian
|
||||
+ fieldtable support for classes
|
||||
|
||||
Revision 1.24 2000/03/27 21:51:19 pierre
|
||||
* fix for bug 739
|
||||
|
||||
Revision 1.23 2000/03/19 14:56:38 florian
|
||||
|
||||
@ -3333,11 +3333,7 @@ Const local_symtable_index : longint = $8001;
|
||||
end;
|
||||
vmt_offset:=symtable^.datasize;
|
||||
inc(symtable^.datasize,target_os.size_of_pointer);
|
||||
{$ifdef INCLUDEOK}
|
||||
include(objectoptions,oo_has_vmt);
|
||||
{$else}
|
||||
objectoptions:=objectoptions+[oo_has_vmt];
|
||||
{$endif}
|
||||
end;
|
||||
end;
|
||||
|
||||
@ -3677,7 +3673,8 @@ Const local_symtable_index : longint = $8001;
|
||||
procedure count_published_properties(sym:pnamedindexobject);
|
||||
{$ifndef fpc}far;{$endif}
|
||||
begin
|
||||
if needs_prop_entry(psym(sym)) then
|
||||
if needs_prop_entry(psym(sym)) and
|
||||
(psym(sym)^.typ<>varsym) then
|
||||
inc(count);
|
||||
end;
|
||||
|
||||
@ -3734,6 +3731,7 @@ Const local_symtable_index : longint = $8001;
|
||||
case psym(sym)^.typ of
|
||||
varsym:
|
||||
begin
|
||||
{$ifdef dummy}
|
||||
if not(pvarsym(sym)^.vartype.def^.deftype=objectdef) or
|
||||
not(pobjectdef(pvarsym(sym)^.vartype.def)^.is_class) then
|
||||
internalerror(1509992);
|
||||
@ -3753,6 +3751,7 @@ Const local_symtable_index : longint = $8001;
|
||||
rttilist^.concat(new(pai_const,init_8bit(proctypesinfo)));
|
||||
rttilist^.concat(new(pai_const,init_8bit(length(pvarsym(sym)^.name))));
|
||||
rttilist^.concat(new(pai_string,init(pvarsym(sym)^.name)));
|
||||
{$endif dummy}
|
||||
end;
|
||||
propertysym:
|
||||
begin
|
||||
@ -3789,7 +3788,10 @@ Const local_symtable_index : longint = $8001;
|
||||
if needs_prop_entry(psym(sym)) then
|
||||
case psym(sym)^.typ of
|
||||
varsym:
|
||||
;
|
||||
{ now ignored:
|
||||
pvarsym(sym)^.vartype.def^.get_rtti_label;
|
||||
}
|
||||
propertysym:
|
||||
ppropertysym(sym)^.proptype.def^.get_rtti_label;
|
||||
else
|
||||
@ -3818,6 +3820,112 @@ Const local_symtable_index : longint = $8001;
|
||||
end;
|
||||
end;
|
||||
|
||||
type
|
||||
tclasslistitem = object(tlinkedlist_item)
|
||||
index : longint;
|
||||
p : pobjectdef;
|
||||
end;
|
||||
pclasslistitem = ^tclasslistitem;
|
||||
|
||||
var
|
||||
classtablelist : tlinkedlist;
|
||||
tablecount : longint;
|
||||
|
||||
function searchclasstablelist(p : pobjectdef) : pclasslistitem;
|
||||
|
||||
var
|
||||
hp : pclasslistitem;
|
||||
|
||||
begin
|
||||
hp:=pclasslistitem(classtablelist.first);
|
||||
while assigned(hp) do
|
||||
if hp^.p=p then
|
||||
begin
|
||||
searchclasstablelist:=hp;
|
||||
exit;
|
||||
end
|
||||
else
|
||||
hp:=pclasslistitem(hp^.next);
|
||||
searchclasstablelist:=nil;
|
||||
end;
|
||||
|
||||
procedure count_published_fields(sym:pnamedindexobject);
|
||||
{$ifndef fpc}far;{$endif}
|
||||
|
||||
var
|
||||
hp : pclasslistitem;
|
||||
|
||||
begin
|
||||
if needs_prop_entry(psym(sym)) and
|
||||
(psym(sym)^.typ=varsym) then
|
||||
begin
|
||||
if pvarsym(sym)^.vartype.def^.deftype<>objectdef then
|
||||
internalerror(0206001);
|
||||
hp:=searchclasstablelist(pobjectdef(pvarsym(sym)^.vartype.def));
|
||||
if not(assigned(hp)) then
|
||||
begin
|
||||
hp:=new(pclasslistitem,init);
|
||||
hp^.p:=pobjectdef(pvarsym(sym)^.vartype.def);
|
||||
hp^.index:=tablecount;
|
||||
classtablelist.concat(hp);
|
||||
inc(tablecount);
|
||||
end;
|
||||
inc(count);
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure writefields(sym:pnamedindexobject);
|
||||
{$ifndef fpc}far;{$endif}
|
||||
|
||||
var
|
||||
hp : pclasslistitem;
|
||||
|
||||
begin
|
||||
if needs_prop_entry(psym(sym)) and
|
||||
(psym(sym)^.typ=varsym) then
|
||||
begin
|
||||
rttilist^.concat(new(pai_const,init_32bit(pvarsym(sym)^.address)));
|
||||
hp:=searchclasstablelist(pobjectdef(pvarsym(sym)^.vartype.def));
|
||||
if not(assigned(hp)) then
|
||||
internalerror(0206002);
|
||||
rttilist^.concat(new(pai_const,init_32bit(hp^.index)));
|
||||
rttilist^.concat(new(pai_const,init_8bit(length(pvarsym(sym)^.name))));
|
||||
rttilist^.concat(new(pai_string,init(pvarsym(sym)^.name)));
|
||||
end;
|
||||
end;
|
||||
|
||||
function tobjectdef.generate_field_table : pasmlabel;
|
||||
|
||||
var
|
||||
fieldtable,
|
||||
classtable : pasmlabel;
|
||||
hp : pclasslistitem;
|
||||
|
||||
begin
|
||||
classtablelist.init;
|
||||
getlabel(fieldtable);
|
||||
getlabel(classtable);
|
||||
count:=0;
|
||||
tablecount:=0;
|
||||
symtable^.foreach({$ifdef FPC}@{$endif}count_published_fields);
|
||||
rttilist^.concat(new(pai_label,init(fieldtable)));
|
||||
rttilist^.concat(new(pai_const,init_16bit(count)));
|
||||
rttilist^.concat(new(pai_const_symbol,init(classtable)));
|
||||
symtable^.foreach({$ifdef FPC}@{$endif}writefields);
|
||||
|
||||
{ generate the class table }
|
||||
rttilist^.concat(new(pai_label,init(classtable)));
|
||||
rttilist^.concat(new(pai_const,init_16bit(tablecount)));
|
||||
hp:=pclasslistitem(classtablelist.first);
|
||||
while assigned(hp) do
|
||||
begin
|
||||
rttilist^.concat(new(pai_const_symbol,initname(pobjectdef(hp^.p)^.vmt_mangledname)));
|
||||
hp:=pclasslistitem(hp^.next);
|
||||
end;
|
||||
|
||||
generate_field_table:=fieldtable;
|
||||
classtablelist.done;
|
||||
end;
|
||||
|
||||
function tobjectdef.next_free_name_index : longint;
|
||||
var
|
||||
@ -3901,7 +4009,6 @@ Const local_symtable_index : longint = $8001;
|
||||
get_rtti_label:=rtti_name;
|
||||
end;
|
||||
|
||||
|
||||
{****************************************************************************
|
||||
TFORWARDDEF
|
||||
****************************************************************************}
|
||||
@ -3954,7 +4061,10 @@ Const local_symtable_index : longint = $8001;
|
||||
|
||||
{
|
||||
$Log$
|
||||
Revision 1.199 2000-04-01 14:17:08 peter
|
||||
Revision 1.200 2000-06-02 18:48:47 florian
|
||||
+ fieldtable support for classes
|
||||
|
||||
Revision 1.199 2000/04/01 14:17:08 peter
|
||||
* arraydef.elesize returns 4 when strings are found in an openarray,
|
||||
arrayconstructor. Since only the pointers to the strings are stored
|
||||
|
||||
|
||||
@ -216,6 +216,7 @@
|
||||
procedure generate_rtti;virtual;
|
||||
procedure write_rtti_data;virtual;
|
||||
procedure write_child_rtti_data;virtual;
|
||||
function generate_field_table : pasmlabel;
|
||||
end;
|
||||
|
||||
pclassrefdef = ^tclassrefdef;
|
||||
@ -530,7 +531,10 @@
|
||||
|
||||
{
|
||||
$Log$
|
||||
Revision 1.53 2000-02-09 13:23:04 peter
|
||||
Revision 1.54 2000-06-02 18:48:48 florian
|
||||
+ fieldtable support for classes
|
||||
|
||||
Revision 1.53 2000/02/09 13:23:04 peter
|
||||
* log truncated
|
||||
|
||||
Revision 1.52 2000/02/04 20:00:22 florian
|
||||
@ -607,4 +611,4 @@
|
||||
* C alignment added for records
|
||||
* PPU version increased to solve .12 <-> .13 probs
|
||||
|
||||
}
|
||||
}
|
||||
@ -71,6 +71,7 @@ unit symtable;
|
||||
ptypesym = ^ttypesym;
|
||||
penumsym = ^tenumsym;
|
||||
pprocsym = ^tprocsym;
|
||||
tcallback = procedure(p : psym);
|
||||
|
||||
pref = ^tref;
|
||||
tref = object
|
||||
@ -162,8 +163,6 @@ unit symtable;
|
||||
of a unit }
|
||||
staticppusymtable);
|
||||
|
||||
tcallback = procedure(p : psym);
|
||||
|
||||
tsearchhasharray = array[0..hasharraysize-1] of psym;
|
||||
psearchhasharray = ^tsearchhasharray;
|
||||
|
||||
@ -2925,7 +2924,10 @@ implementation
|
||||
end.
|
||||
{
|
||||
$Log$
|
||||
Revision 1.93 2000-06-01 19:07:52 peter
|
||||
Revision 1.94 2000-06-02 18:48:48 florian
|
||||
+ fieldtable support for classes
|
||||
|
||||
Revision 1.93 2000/06/01 19:07:52 peter
|
||||
* delphi/tp mode fixes for dup id checking (tbs319,tbf320)
|
||||
|
||||
Revision 1.92 2000/05/23 14:15:44 pierre
|
||||
|
||||
Loading…
Reference in New Issue
Block a user