paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-11-23 01:59:41 +01:00
Code Issues Packages Projects Releases Wiki Activity

* write only unique property names in rtti

Browse Source 
git-svn-id: trunk@2007 -
This commit is contained in:
peter 2005-12-20 14:44:48 +00:00
parent b561749dea
commit 68e56b9fc7
4 changed files with 226 additions and 180 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.gitattributes vendored
View File

@ -5638,6 +5638,7 @@ tests/test/trtti1.pp svneol=native#text/plain
tests/test/trtti2.pp svneol=native#text/plain tests/test/trtti2.pp svneol=native#text/plain
tests/test/trtti3.pp svneol=native#text/plain tests/test/trtti3.pp svneol=native#text/plain
tests/test/trtti4.pp svneol=native#text/plain tests/test/trtti4.pp svneol=native#text/plain
tests/test/trtti5.pp svneol=native#text/plain
tests/test/tset1.pp svneol=native#text/plain tests/test/tset1.pp svneol=native#text/plain
tests/test/tset2.pp svneol=native#text/plain tests/test/tset2.pp svneol=native#text/plain
tests/test/tstack.pp svneol=native#text/plain tests/test/tstack.pp svneol=native#text/plain

330
compiler/symdef.pas
View File

@ -214,6 +214,7 @@ interface
tobjectdef = class(tabstractrecorddef) tobjectdef = class(tabstractrecorddef)
private private
procedure count_published_properties(sym:tnamedindexitem;arg:pointer); procedure count_published_properties(sym:tnamedindexitem;arg:pointer);
procedure collect_published_properties(sym:tnamedindexitem;arg:pointer);
procedure write_property_info(sym : tnamedindexitem;arg:pointer); procedure write_property_info(sym : tnamedindexitem;arg:pointer);
procedure generate_published_child_rtti(sym : tnamedindexitem;arg:pointer); procedure generate_published_child_rtti(sym : tnamedindexitem;arg:pointer);
procedure count_published_fields(sym:tnamedindexitem;arg:pointer); procedure count_published_fields(sym:tnamedindexitem;arg:pointer);
@ -255,7 +256,6 @@ interface
function rtti_name : string; function rtti_name : string;
procedure check_forwards; procedure check_forwards;
function is_related(d : tdef) : boolean;override; function is_related(d : tdef) : boolean;override;
function next_free_name_index : longint;
procedure insertvmt; procedure insertvmt;
procedure set_parent(c : tobjectdef); procedure set_parent(c : tobjectdef);
function searchdestructor : tprocdef; function searchdestructor : tprocdef;
@ -4175,6 +4175,55 @@ implementation
TOBJECTDEF TOBJECTDEF
***************************************************************************} ***************************************************************************}
type
tproptablelistitem = class(TLinkedListItem)
index : longint;
def : tobjectdef;
end;
tpropnamelistitem = class(TLinkedListItem)
index : longint;
name : stringid;
owner : tsymtable;
end;
var
proptablelist : tlinkedlist;
propnamelist : tlinkedlist;
function searchproptablelist(p : tobjectdef) : tproptablelistitem;
var
hp : tproptablelistitem;
begin
hp:=tproptablelistitem(proptablelist.first);
while assigned(hp) do
if hp.def=p then
begin
result:=hp;
exit;
end
else
hp:=tproptablelistitem(hp.next);
result:=nil;
end;
function searchpropnamelist(const n:string) : tpropnamelistitem;
var
hp : tpropnamelistitem;
begin
hp:=tpropnamelistitem(propnamelist.first);
while assigned(hp) do
if hp.name=n then
begin
result:=hp;
exit;
end
else
hp:=tpropnamelistitem(hp.next);
result:=nil;
end;
constructor tobjectdef.create(ot : tobjectdeftype;const n : string;c : tobjectdef); constructor tobjectdef.create(ot : tobjectdeftype;const n : string;c : tobjectdef);
begin begin
@ -4499,41 +4548,16 @@ implementation
end; end;
(* procedure tobjectdef._searchdestructor(sym : tnamedindexitem;arg:pointer);
var
p : pprocdeflist;
begin
{ if we found already a destructor, then we exit }
if assigned(sd) then
exit;
if tsym(sym).typ=procsym then
begin
p:=tprocsym(sym).defs;
while assigned(p) do
begin
if p^.def.proctypeoption=potype_destructor then
begin
sd:=p^.def;
exit;
end;
p:=p^.next;
end;
end;
end;*)
procedure _searchdestructor(sym:Tnamedindexitem;sd:pointer); procedure _searchdestructor(sym:Tnamedindexitem;sd:pointer);
begin
begin
{ if we found already a destructor, then we exit } { if we found already a destructor, then we exit }
if (ppointer(sd)^=nil) and if (ppointer(sd)^=nil) and
(Tsym(sym).typ=procsym) then (Tsym(sym).typ=procsym) then
ppointer(sd)^:=Tprocsym(sym).search_procdef_bytype(potype_destructor); ppointer(sd)^:=Tprocsym(sym).search_procdef_bytype(potype_destructor);
end; end;
function tobjectdef.searchdestructor : tprocdef; function tobjectdef.searchdestructor : tprocdef;
var var
o : tobjectdef; o : tobjectdef;
sd : tprocdef; sd : tprocdef;
@ -4628,17 +4652,38 @@ implementation
end; end;
procedure tobjectdef.collect_published_properties(sym:tnamedindexitem;arg:pointer);
var
hp : tpropnamelistitem;
begin
if (tsym(sym).typ=propertysym) and
(sp_published in tsym(sym).symoptions) then
begin
hp:=searchpropnamelist(tsym(sym).name);
if not(assigned(hp)) then
begin
hp:=tpropnamelistitem.create;
hp.name:=tsym(sym).name;
hp.index:=propnamelist.count;
hp.owner:=tsym(sym).owner;
propnamelist.concat(hp);
end;
end;
end;
procedure tobjectdef.count_published_properties(sym:tnamedindexitem;arg:pointer); procedure tobjectdef.count_published_properties(sym:tnamedindexitem;arg:pointer);
begin begin
if needs_prop_entry(tsym(sym)) and if (tsym(sym).typ=propertysym) and
(tsym(sym).typ<>fieldvarsym) then (sp_published in tsym(sym).symoptions) then
inc(count); inc(plongint(arg)^);
end; end;
procedure tobjectdef.write_property_info(sym : tnamedindexitem;arg:pointer); procedure tobjectdef.write_property_info(sym : tnamedindexitem;arg:pointer);
var var
proctypesinfo : byte; proctypesinfo : byte;
propnameitem : tpropnamelistitem;
procedure writeproc(proc : tsymlist; shiftvalue : byte); procedure writeproc(proc : tsymlist; shiftvalue : byte);
@ -4708,62 +4753,37 @@ implementation
end; end;
begin begin
if needs_prop_entry(tsym(sym)) then if (tsym(sym).typ=propertysym) and
case tsym(sym).typ of (sp_published in tsym(sym).symoptions) then
fieldvarsym: begin
begin if ppo_indexed in tpropertysym(sym).propoptions then
{$ifdef dummy} proctypesinfo:=$40
if not(tvarsym(sym).vartype.def.deftype=objectdef) or else
not(tobjectdef(tvarsym(sym).vartype.def).is_class) then proctypesinfo:=0;
internalerror(1509992); asmlist[al_rtti].concat(Tai_const.Create_sym(tstoreddef(tpropertysym(sym).proptype.def).get_rtti_label(fullrtti)));
{ access to implicit class property as field } writeproc(tpropertysym(sym).readaccess,0);
proctypesinfo:=(0 shl 0) or (0 shl 2) or (0 shl 4); writeproc(tpropertysym(sym).writeaccess,2);
asmlist[al_rtti].concat(Tai_const_symbol.Createname(tvarsym(sym.vartype.def.get_rtti_label),AT_DATA,0)); { isn't it stored ? }
asmlist[al_rtti].concat(Tai_const.create(ait_const_ptr,tvarsym(sym.address))); if not(ppo_stored in tpropertysym(sym).propoptions) then
asmlist[al_rtti].concat(Tai_const.create(ait_const_ptr,tvarsym(sym.address))); begin
{ by default stored } asmlist[al_rtti].concat(Tai_const.create_sym(nil));
asmlist[al_rtti].concat(Tai_const.Create_32bit(1)); proctypesinfo:=proctypesinfo or (3 shl 4);
{ index as well as ... } end
asmlist[al_rtti].concat(Tai_const.Create_32bit(0)); else
{ default value are zero } writeproc(tpropertysym(sym).storedaccess,4);
asmlist[al_rtti].concat(Tai_const.Create_32bit(0)); asmlist[al_rtti].concat(Tai_const.Create_32bit(tpropertysym(sym).index));
asmlist[al_rtti].concat(Tai_const.Create_16bit(count)); asmlist[al_rtti].concat(Tai_const.Create_32bit(tpropertysym(sym).default));
inc(count); propnameitem:=searchpropnamelist(tpropertysym(sym).name);
asmlist[al_rtti].concat(Tai_const.Create_8bit(proctypesinfo)); if not assigned(propnameitem) then
asmlist[al_rtti].concat(Tai_const.Create_8bit(length(tvarsym(sym.realname)))); internalerror(200512201);
asmlist[al_rtti].concat(Tai_string.Create(tvarsym(sym.realname))); asmlist[al_rtti].concat(Tai_const.Create_16bit(propnameitem.index));
{$endif dummy} asmlist[al_rtti].concat(Tai_const.Create_8bit(proctypesinfo));
end; asmlist[al_rtti].concat(Tai_const.Create_8bit(length(tpropertysym(sym).realname)));
propertysym: asmlist[al_rtti].concat(Tai_string.Create(tpropertysym(sym).realname));
begin
if ppo_indexed in tpropertysym(sym).propoptions then
proctypesinfo:=$40
else
proctypesinfo:=0;
asmlist[al_rtti].concat(Tai_const.Create_sym(tstoreddef(tpropertysym(sym).proptype.def).get_rtti_label(fullrtti)));
writeproc(tpropertysym(sym).readaccess,0);
writeproc(tpropertysym(sym).writeaccess,2);
{ isn't it stored ? }
if not(ppo_stored in tpropertysym(sym).propoptions) then
begin
asmlist[al_rtti].concat(Tai_const.create_sym(nil));
proctypesinfo:=proctypesinfo or (3 shl 4);
end
else
writeproc(tpropertysym(sym).storedaccess,4);
asmlist[al_rtti].concat(Tai_const.Create_32bit(tpropertysym(sym).index));
asmlist[al_rtti].concat(Tai_const.Create_32bit(tpropertysym(sym).default));
asmlist[al_rtti].concat(Tai_const.Create_16bit(count));
inc(count);
asmlist[al_rtti].concat(Tai_const.Create_8bit(proctypesinfo));
asmlist[al_rtti].concat(Tai_const.Create_8bit(length(tpropertysym(sym).realname)));
asmlist[al_rtti].concat(Tai_string.Create(tpropertysym(sym).realname));
{$ifdef cpurequiresproperalignment} {$ifdef cpurequiresproperalignment}
asmlist[al_rtti].concat(Tai_align.Create(sizeof(TConstPtrUInt))); asmlist[al_rtti].concat(Tai_align.Create(sizeof(TConstPtrUInt)));
{$endif cpurequiresproperalignment} {$endif cpurequiresproperalignment}
end; end;
else internalerror(1509992);
end;
end; end;
@ -4797,61 +4817,31 @@ implementation
end; end;
type
tclasslistitem = class(TLinkedListItem)
index : longint;
p : tobjectdef;
end;
var
classtablelist : tlinkedlist;
tablecount : longint;
function searchclasstablelist(p : tobjectdef) : tclasslistitem;
var
hp : tclasslistitem;
begin
hp:=tclasslistitem(classtablelist.first);
while assigned(hp) do
if hp.p=p then
begin
searchclasstablelist:=hp;
exit;
end
else
hp:=tclasslistitem(hp.next);
searchclasstablelist:=nil;
end;
procedure tobjectdef.count_published_fields(sym:tnamedindexitem;arg:pointer); procedure tobjectdef.count_published_fields(sym:tnamedindexitem;arg:pointer);
var var
hp : tclasslistitem; hp : tproptablelistitem;
begin begin
if needs_prop_entry(tsym(sym)) and if (tsym(sym).typ=fieldvarsym) and
(tsym(sym).typ=fieldvarsym) then (sp_published in tsym(sym).symoptions) then
begin begin
if tfieldvarsym(sym).vartype.def.deftype<>objectdef then if tfieldvarsym(sym).vartype.def.deftype<>objectdef then
internalerror(0206001); internalerror(0206001);
hp:=searchclasstablelist(tobjectdef(tfieldvarsym(sym).vartype.def)); hp:=searchproptablelist(tobjectdef(tfieldvarsym(sym).vartype.def));
if not(assigned(hp)) then if not(assigned(hp)) then
begin begin
hp:=tclasslistitem.create; hp:=tproptablelistitem.create;
hp.p:=tobjectdef(tfieldvarsym(sym).vartype.def); hp.def:=tobjectdef(tfieldvarsym(sym).vartype.def);
hp.index:=tablecount; hp.index:=proptablelist.count+1;
classtablelist.concat(hp); proptablelist.concat(hp);
inc(tablecount);
end; end;
inc(count); inc(plongint(arg)^);
end; end;
end; end;
procedure tobjectdef.writefields(sym:tnamedindexitem;arg:pointer); procedure tobjectdef.writefields(sym:tnamedindexitem;arg:pointer);
var var
hp : tclasslistitem; hp : tproptablelistitem;
begin begin
if needs_prop_entry(tsym(sym)) and if needs_prop_entry(tsym(sym)) and
(tsym(sym).typ=fieldvarsym) then (tsym(sym).typ=fieldvarsym) then
@ -4860,7 +4850,7 @@ implementation
asmlist[al_rtti].concat(Tai_align.Create(sizeof(AInt))); asmlist[al_rtti].concat(Tai_align.Create(sizeof(AInt)));
{$endif cpurequiresproperalignment} {$endif cpurequiresproperalignment}
asmlist[al_rtti].concat(Tai_const.Create_aint(tfieldvarsym(sym).fieldoffset)); asmlist[al_rtti].concat(Tai_const.Create_aint(tfieldvarsym(sym).fieldoffset));
hp:=searchclasstablelist(tobjectdef(tfieldvarsym(sym).vartype.def)); hp:=searchproptablelist(tobjectdef(tfieldvarsym(sym).vartype.def));
if not(assigned(hp)) then if not(assigned(hp)) then
internalerror(0206002); internalerror(0206002);
asmlist[al_rtti].concat(Tai_const.Create_16bit(hp.index)); asmlist[al_rtti].concat(Tai_const.Create_16bit(hp.index));
@ -4874,62 +4864,57 @@ implementation
var var
fieldtable, fieldtable,
classtable : tasmlabel; classtable : tasmlabel;
hp : tclasslistitem; hp : tproptablelistitem;
fieldcount : longint;
begin begin
classtablelist:=TLinkedList.Create; proptablelist:=TLinkedList.Create;
objectlibrary.getdatalabel(fieldtable); objectlibrary.getdatalabel(fieldtable);
objectlibrary.getdatalabel(classtable); objectlibrary.getdatalabel(classtable);
count:=0;
tablecount:=0;
maybe_new_object_file(asmlist[al_rtti]); maybe_new_object_file(asmlist[al_rtti]);
new_section(asmlist[al_rtti],sec_rodata,classtable.name,const_align(sizeof(aint))); new_section(asmlist[al_rtti],sec_rodata,classtable.name,const_align(sizeof(aint)));
{ fields } { fields }
symtable.foreach({$ifdef FPC}@{$endif}count_published_fields,nil); fieldcount:=0;
symtable.foreach(@count_published_fields,@fieldcount);
asmlist[al_rtti].concat(Tai_label.Create(fieldtable)); asmlist[al_rtti].concat(Tai_label.Create(fieldtable));
asmlist[al_rtti].concat(Tai_const.Create_16bit(count)); asmlist[al_rtti].concat(Tai_const.Create_16bit(fieldcount));
{$ifdef cpurequiresproperalignment} {$ifdef cpurequiresproperalignment}
asmlist[al_rtti].concat(Tai_align.Create(sizeof(TConstPtrUInt))); asmlist[al_rtti].concat(Tai_align.Create(sizeof(TConstPtrUInt)));
{$endif cpurequiresproperalignment} {$endif cpurequiresproperalignment}
asmlist[al_rtti].concat(Tai_const.Create_sym(classtable)); asmlist[al_rtti].concat(Tai_const.Create_sym(classtable));
symtable.foreach({$ifdef FPC}@{$endif}writefields,nil); symtable.foreach(@writefields,nil);
{ generate the class table } { generate the class table }
asmlist[al_rtti].concat(tai_align.create(const_align(sizeof(aint)))); asmlist[al_rtti].concat(tai_align.create(const_align(sizeof(aint))));
asmlist[al_rtti].concat(Tai_label.Create(classtable)); asmlist[al_rtti].concat(Tai_label.Create(classtable));
asmlist[al_rtti].concat(Tai_const.Create_16bit(tablecount)); asmlist[al_rtti].concat(Tai_const.Create_16bit(proptablelist.count));
{$ifdef cpurequiresproperalignment} {$ifdef cpurequiresproperalignment}
asmlist[al_rtti].concat(Tai_align.Create(sizeof(TConstPtrUInt))); asmlist[al_rtti].concat(Tai_align.Create(sizeof(TConstPtrUInt)));
{$endif cpurequiresproperalignment} {$endif cpurequiresproperalignment}
hp:=tclasslistitem(classtablelist.first); hp:=tproptablelistitem(proptablelist.first);
while assigned(hp) do while assigned(hp) do
begin begin
asmlist[al_rtti].concat(Tai_const.Createname(tobjectdef(hp.p).vmt_mangledname,AT_DATA,0)); asmlist[al_rtti].concat(Tai_const.Createname(tobjectdef(hp.def).vmt_mangledname,AT_DATA,0));
hp:=tclasslistitem(hp.next); hp:=tproptablelistitem(hp.next);
end; end;
generate_field_table:=fieldtable; generate_field_table:=fieldtable;
classtablelist.free; proptablelist.free;
end; proptablelist:=nil;
function tobjectdef.next_free_name_index : longint;
var
i : longint;
begin
if assigned(childof) and (oo_can_have_published in childof.objectoptions) then
i:=childof.next_free_name_index
else
i:=0;
count:=0;
symtable.foreach(@count_published_properties,nil);
next_free_name_index:=i+count;
end; end;
procedure tobjectdef.write_rtti_data(rt:trttitype); procedure tobjectdef.write_rtti_data(rt:trttitype);
procedure collect_unique_published_props(pd:tobjectdef);
begin
if assigned(pd.childof) then
collect_unique_published_props(pd.childof);
pd.symtable.foreach(@collect_published_properties,nil);
end;
var var
i : longint; i : longint;
propcount : longint;
begin begin
case objecttype of case objecttype of
odt_class: odt_class:
@ -4965,6 +4950,10 @@ implementation
end; end;
fullrtti : fullrtti :
begin begin
{ Collect unique property names with nameindex }
propnamelist:=TLinkedList.Create;
collect_unique_published_props(self);
if not(objecttype in [odt_interfacecom,odt_interfacecorba]) then if not(objecttype in [odt_interfacecom,odt_interfacecorba]) then
begin begin
if (oo_has_vmt in objectoptions) then if (oo_has_vmt in objectoptions) then
@ -4982,15 +4971,8 @@ implementation
if objecttype in [odt_object,odt_class] then if objecttype in [odt_object,odt_class] then
begin begin
{ count total number of properties } { total number of unique properties }
if assigned(childof) and (oo_can_have_published in childof.objectoptions) then asmlist[al_rtti].concat(Tai_const.Create_16bit(propnamelist.count));
count:=childof.next_free_name_index
else
count:=0;
{ write it }
symtable.foreach(@count_published_properties,nil);
asmlist[al_rtti].concat(Tai_const.Create_16bit(count));
end end
else else
{ interface: write flags, iid and iidstr } { interface: write flags, iid and iidstr }
@ -5038,28 +5020,20 @@ implementation
{$endif cpurequiresproperalignment} {$endif cpurequiresproperalignment}
end; end;
{ write published properties for this object }
if objecttype in [odt_object,odt_class] then if objecttype in [odt_object,odt_class] then
begin begin
{ write published properties count } propcount:=0;
count:=0; symtable.foreach(@count_published_properties,@propcount);
symtable.foreach(@count_published_properties,nil); asmlist[al_rtti].concat(Tai_const.Create_16bit(propcount));
asmlist[al_rtti].concat(Tai_const.Create_16bit(count));
{$ifdef cpurequiresproperalignment} {$ifdef cpurequiresproperalignment}
asmlist[al_rtti].concat(Tai_align.Create(sizeof(TConstPtrUInt))); asmlist[al_rtti].concat(Tai_align.Create(sizeof(TConstPtrUInt)));
{$endif cpurequiresproperalignment} {$endif cpurequiresproperalignment}
end; end;
{ count is used to write nameindex }
{ but we need an offset of the owner }
{ to give each property an own slot }
if assigned(childof) and (oo_can_have_published in childof.objectoptions) then
count:=childof.next_free_name_index
else
count:=0;
symtable.foreach(@write_property_info,nil); symtable.foreach(@write_property_info,nil);
propnamelist.free;
propnamelist:=nil;
end; end;
end; end;
end; end;

10
rtl/objpas/typinfo.pp
View File

@ -600,9 +600,13 @@ Var
TP : PPropInfo; TP : PPropInfo;
Count : Longint; Count : Longint;
begin begin
// Get this objects TOTAL published properties count
TD:=GetTypeData(TypeInfo);
// Clear list
FillChar(PropList^,TD^.PropCount*sizeof(Pointer),0);
repeat repeat
TD:=GetTypeData(TypeInfo); TD:=GetTypeData(TypeInfo);
// Get this objects TOTAL published properties count // published properties count for this object
TP:=aligntoptr(PPropInfo(aligntoptr((@TD^.UnitName+Length(TD^.UnitName)+1)))); TP:=aligntoptr(PPropInfo(aligntoptr((@TD^.UnitName+Length(TD^.UnitName)+1))));
Count:=PWord(TP)^; Count:=PWord(TP)^;
// Now point TP to first propinfo record. // Now point TP to first propinfo record.
@ -610,7 +614,9 @@ begin
tp:=aligntoptr(tp); tp:=aligntoptr(tp);
While Count>0 do While Count>0 do
begin begin
PropList^[TP^.NameIndex]:=TP; // Don't overwrite properties with the same name
if PropList^[TP^.NameIndex]=nil then
PropList^[TP^.NameIndex]:=TP;
// Point to TP next propinfo record. // Point to TP next propinfo record.
// Located at Name[Length(Name)+1] ! // Located at Name[Length(Name)+1] !
TP:=aligntoptr(PPropInfo(pointer(@TP^.Name)+PByte(@TP^.Name)^+1)); TP:=aligntoptr(PPropInfo(pointer(@TP^.Name)+PByte(@TP^.Name)^+1));

65
tests/test/trtti5.pp Normal file
View File

@ -0,0 +1,65 @@
{$IFDEF FPC}
{$mode objfpc}{$H+}
{$ELSE}
{$APPTYPE CONSOLE}
{$ENDIF}
uses
SysUtils,
TypInfo,
Classes;
type
TAObject = class(TPersistent)
private
FIntProp: Integer;
published
property IntProp: Integer read FIntProp write FIntProp;
end;
TBObject = class(TAObject)
published
property IntProp default 1;
end;
TCObject = class(TBObject)
published
property IntProp default 2;
end;
procedure ShowProperties;
var
Obj: TCObject;
i: Longint;
lPropFilter: TTypeKinds;
lCount: Longint;
lSize: Integer;
lList: PPropList;
begin
Obj := TCObject.Create;
lPropFilter := [tkInteger, tkLString {$ifdef FPC}, tkAString{$endif}];
lCount := GetPropList(Obj.ClassInfo, lPropFilter, nil, false);
lSize := lCount * SizeOf(Pointer);
GetMem(lList, lSize);
Writeln('Total property Count: ' + IntToStr(lCount));
lCount := GetPropList(Obj.ClassInfo, lPropFilter, lList, false);
for i := 0 to lCount-1 do
begin
Writeln('Property '+IntToStr(i+1)+': ' + lList^[i]^.Name);
end;
if lCount<>1 then
halt(1);
FreeMem(lList);
Obj.Free;
Writeln('---------------');
end;
begin
ShowProperties;
end.