On 17 May 2012, at 23:32, Joost van der Sluis wrote:
>> I'm trying to implement extended RTTI property attributes as
>> supported by recent Delphi versions.
>>Please add this functionality first to a separate branch for easier
>>reviewing.
I could, but I attached a patch first. Before I commit this to a branch
I want to know that I'm on the right track. Could you and/or others have
a look at the patch?
I'm especially interested if things are done in the right units, and if
the code in ptypes.pas is acceptable.
Attached are the patch and a simple test-program.
First an example what class-attributes are:
type
TMyObject = class
published
[TAttributeClassName('param1','param2')]
property AProperty;
end;
When you request the class-property that belongs to the property
AProperty, then you get an instance of the TAttributeClassName class
which is constructed by calling it's constructor with the supplied
parameters. (In this case 'param1' and 'param2')
How I implemented this:
For each attribute a function is generated that returns a class-instance
of the attribute. This function is generated in ptypes by creating a
tcgprocinfo. All the necessary nodes are added to it and then
tcgprocinfo.generate_code is executed.
In the rtti-info (ppropinfo) the address of this function is stored so
that it is possible to read those attributes.
If I'm on the right track I'll add a branch with this patch and work
from there. Some issues:
- In Delphi an attribute-class has to be defined as a TCustomAttribute.
That way it's also clear which constructor has to be called. For now, it
calls the first constructor it can find.
- The rtti-info is now stored inside PPropInfo, I don't think that this
is how Delphi does it, also because in Delphi you need the 'rtti' unit
to get this information. I've added it to typinfo and later on a 'rtti'
unit could be written as a wrapper around typinfo.
- When we add more rtti-information to types we need a way to specify
what to generate and what not and where to store it. Especially because
the rtti-info will grow.
- No error is generated when you define an attribute for something else
then a property.
- The attribute-definition is stored in the .ppu, but that's not really
needed. Since at compile-time this information is never used by another
unit. I used it for debugging though (with ppudump) A side-effect is
that when an attribute is changed, a recompilation of the unit is
forced. Do we want that? (For now only the attribute-type is stored in
the ppu, not the parameters)
Joost.
--
Met vriendelijke groeten,
Joost van der Sluis
CNOC Informatiesystemen en Netwerken
http://www.cnoc.nl
Index: compiler/ptype.pas
===================================================================
--- compiler/ptype.pas (revision 21375)
+++ compiler/ptype.pas (working copy)
@@ -60,11 +60,14 @@
{ parse hint directives (platform, deprecated, ...) for a procdef }
procedure maybe_parse_hint_directives(pd:tprocdef);
+ { generate hidden RTTI attribute functions which return the attribute classes }
+ procedure generate_rttiattribute_procs;
+
implementation
uses
{ common }
- cutils,
+ cutils,sysutils,pparautl,
{ global }
globals,tokens,verbose,constexp,
systems,
@@ -80,10 +83,11 @@
fmodule,
{ pass 1 }
node,ncgrtti,nobj,
- nmat,nadd,ncal,nset,ncnv,ninl,ncon,nld,nflw,
+ nmat,nadd,ncal,nset,ncnv,ninl,ncon,nld,nflw,nmem,nbas,
+ ncgutil,
{ parser }
scanner,
- pbase,pexpr,pdecsub,pdecvar,pdecobj,pdecl,pgenutil
+ pbase,pexpr,pdecsub,pdecvar,pdecobj,pdecl,pgenutil,psub
{$ifdef jvm}
,pjvm
{$endif}
@@ -1618,7 +1622,138 @@
read_named_type(def,nil,nil,nil,parseprocvardir);
end;
+ procedure generate_rttiattribute_proc(APropertySym: tpropertysym; AnAttribute: trtti_attribute; attribute_index: longint);
+ var
+ pd: tprocdef;
+ aprocsym: tprocsym;
+ st:TSymtable;
+ checkstack : psymtablestackitem;
+ old_current_procinfo : tprocinfo;
+ old_current_structdef: tabstractrecorddef;
+ old_current_genericdef,
+ old_current_specializedef: tstoreddef;
+ block: tblocknode;
+ load: tloadnode;
+ statement: tstatementnode;
+ call: tcallnode;
+ assignment: tassignmentnode;
+ constrdef: tprocdef;
+ vmtaddrnode: tloadvmtaddrnode;
+ begin
+ aprocsym:=tprocsym.create(make_mangledname('_RTTI_ATTRIBUTE_',symtablestack.top,APropertySym.Name+'_'+IntToStr(attribute_index)));
+ symtablestack.top.insert(aprocsym);
+ aprocsym.visibility:=vis_hidden;
+ st:=nil;
+ checkstack:=symtablestack.stack;
+ while assigned(checkstack) do
+ begin
+ st:=checkstack^.symtable;
+ if st.symtabletype in [staticsymtable,globalsymtable,localsymtable] then
+ break;
+ checkstack:=checkstack^.next;
+ end;
+ pd:=tprocdef.create(st.symtablelevel+1);
+ pd.procsym:=aprocsym;
+ pd.proctypeoption:=potype_procedure;
+ pd.visibility:=vis_hidden;
+ pd.fileinfo:=current_tokenpos;
+
+ pd.calcparas;
+
+ { save old state }
+ old_current_procinfo:=current_procinfo;
+ old_current_structdef:=current_structdef;
+ old_current_genericdef:=current_genericdef;
+ old_current_specializedef:=current_specializedef;
+
+ { reset current_procinfo.procdef to nil to be sure that nothing is writing
+ to another procdef }
+ current_procinfo:=nil;
+ current_structdef:=nil;
+ current_genericdef:=nil;
+ current_specializedef:=nil;
+
+ proc_set_mangledname(pd);
+
+ { store the mangledname so that the rtti-info can reference to it }
+ AnAttribute.symbolname:=pd.mangledname;
+
+ { allocate the symbol for this procedure }
+ alloc_proc_symbol(pd);
+
+ current_procinfo:=cprocinfo.create(old_current_procinfo);
+ current_procinfo.procdef:=pd;
+
+ { Insert mangledname }
+ pd.aliasnames.insert(pd.mangledname);
+
+ pd.returndef := ttypesym(AnAttribute.typesym).typedef;
+ insert_funcret_local(pd);
+
+ { Let the proc call the first constructor of the class that can be found }
+ constrdef := tobjectdef(pd.returndef).find_procdef_bytype(potype_constructor);
+
+ load := cloadnode.create(pd.funcretsym,pd.funcretsym.Owner);
+ vmtaddrnode := cloadvmtaddrnode.create(ctypenode.create(pd.returndef));
+ call := ccallnode.create(tcallparanode(AnAttribute.paras),tprocsym(constrdef.procsym), tprocsym(constrdef.procsym).Owner,vmtaddrnode,[]);
+ assignment := cassignmentnode.create(load,call);
+ assignment.resultdef := voidtype;
+
+ statement := cstatementnode.Create(assignment,nil);
+ block := cblocknode.create(statement);
+ block.resultdef := voidtype;
+ tcgprocinfo(current_procinfo).code := block;
+
+ if paraprintnodetree=1 then
+ tcgprocinfo(current_procinfo).printproc( 'after parsing');
+
+ tcgprocinfo(current_procinfo).generate_code;
+
+ current_procinfo.free;
+
+ current_structdef:=old_current_structdef;
+ current_genericdef:=old_current_genericdef;
+ current_specializedef:=old_current_specializedef;
+ current_procinfo:=old_current_procinfo;
+ end;
+
+ procedure generate_rttiattribute_procs_properties(p: TObject; Arg: pointer);
+ var
+ rtti_attributesdef: trtti_attributesdef;
+ i: longint;
+ begin
+ if not((tsym(p).typ=propertysym)
+ ) then
+ exit;
+
+ rtti_attributesdef := tpropertysym(p).rtti_attributesdef;
+ if assigned(rtti_attributesdef) then
+ begin
+ for i := 0 to rtti_attributesdef.get_attribute_count-1 do
+ begin
+ generate_rttiattribute_proc(tpropertysym(p), trtti_attribute(rtti_attributesdef.rtti_attributes[i]),i);
+ end;
+ end;
+ end;
+
+ procedure generate_rttiattribute_procs_classes(p: TObject; Arg: pointer);
+ begin
+ if not((tsym(p).typ=typesym) and
+ (ttypesym(p).typedef.typ in [objectdef])
+ ) then
+ exit;
+ tobjectdef(ttypesym(p).typedef).symtable.SymList.ForEachCall(@generate_rttiattribute_procs_properties,nil);
+ end;
+
+ procedure generate_rttiattribute_procs;
+ begin
+ if assigned(current_module.globalsymtable) then
+ current_module.globalsymtable.SymList.ForEachCall(@generate_rttiattribute_procs_classes,nil);
+ if assigned(current_module.localsymtable) then
+ current_module.localsymtable.SymList.ForEachCall(@generate_rttiattribute_procs_classes,nil);
+ end;
+
procedure write_persistent_type_info(st:tsymtable;is_global:boolean);
var
i : longint;
Index: compiler/ppu.pas
===================================================================
--- compiler/ppu.pas (revision 21375)
+++ compiler/ppu.pas (working copy)
@@ -122,6 +122,7 @@
ibvariantdef = 57;
ibundefineddef = 58;
ibunicodestringdef = 59;
+ ibattributesdef = 60;
{implementation/ObjData}
ibnodetree = 80;
ibasmsymbols = 81;
Index: compiler/pmodules.pas
===================================================================
--- compiler/pmodules.pas (revision 21375)
+++ compiler/pmodules.pas (working copy)
@@ -962,6 +962,8 @@
current_module.mainfilepos:=init_procinfo.entrypos;
end;
+ generate_rttiattribute_procs;
+
{ Generate specializations of objectdefs methods }
generate_specialization_procs;
Index: compiler/pdecobj.pas
===================================================================
--- compiler/pdecobj.pas (revision 21375)
+++ compiler/pdecobj.pas (working copy)
@@ -64,6 +64,7 @@
var
current_objectdef : tobjectdef absolute current_structdef;
+ current_rttiattributesdef : trtti_attributesdef;
procedure constr_destr_finish_head(pd: tprocdef; const astruct: tabstractrecorddef);
@@ -201,6 +202,11 @@
Message(parser_e_enumerator_identifier_required);
consume(_SEMICOLON);
end;
+ if assigned(current_rttiattributesdef) then
+ begin
+ p.rtti_attributesdef := current_rttiattributesdef;
+ current_rttiattributesdef:=nil;
+ end;
{ hint directives, these can be separated by semicolons here,
that needs to be handled here with a loop (PFV) }
while try_consume_hintdirective(p.symoptions,p.deprecatedmsg) do
@@ -955,6 +961,35 @@
end;
+ procedure parse_rttiattributes(var rtti_attributes: trtti_attributesdef);
+ var
+ p: tnode;
+ paras: tnode;
+ begin
+ consume(_LECKKLAMMER);
+ { Parse attribute type }
+ p := factor(false,true);
+
+ if try_to_consume(_LKLAMMER) then
+ begin
+ paras:=parse_paras(false,false,_RKLAMMER);
+ consume(_RKLAMMER);
+ end
+ else
+ paras := nil;
+
+ // Add attribute to attribute list which will be added
+ // to the property which is defined next.
+ if not assigned(rtti_attributes) then
+ rtti_attributes := trtti_attributesdef.create(attributedef);
+ rtti_attributes.addattribute(ttypesym(ttypenode(p).typesym),ttypenode(p).typesymderef,paras);
+
+ p.free;
+
+ consume(_RECKKLAMMER);
+ end;
+
+
procedure parse_object_members;
var
@@ -1054,6 +1089,7 @@
class_fields:=false;
is_final:=false;
final_fields:=false;
+ current_rttiattributesdef:=nil;
object_member_blocktype:=bt_general;
repeat
case token of
@@ -1213,6 +1249,10 @@
fields_allowed:=false;
is_classdef:=false;
end;
+ _LECKKLAMMER:
+ begin
+ parse_rttiattributes(current_rttiattributesdef);
+ end;
_END :
begin
consume(_END);
Index: compiler/symdef.pas
===================================================================
--- compiler/symdef.pas (revision 21375)
+++ compiler/symdef.pas (working copy)
@@ -752,6 +752,24 @@
function getbasedef: tenumdef;
end;
+ trtti_attribute = class
+ typesym : tsym;
+ typesymderef : tderef;
+ paras : tobject;
+ symbolname : string;
+ end;
+
+ trtti_attributesdef = class(tstoreddef)
+ rtti_attributes : TFPObjectList;
+ procedure addattribute(atypesym: tsym; atypesymderef: tderef; aparas: tobject);
+ destructor destroy; override;
+ constructor ppuload(ppufile:tcompilerppufile);
+ procedure ppuwrite(ppufile:tcompilerppufile);override;
+ function get_attribute_count: longint;
+ procedure buildderef;override;
+ procedure deref;override;
+ end;
+
tsetdef = class(tstoreddef)
elementdef : tdef;
elementdefderef : tderef;
@@ -2101,7 +2119,84 @@
GetTypeName:='<enumeration type>';
end;
+{****************************************************************************
+ TRTTI_ATTRIBUTESDEF
+****************************************************************************}
+ procedure trtti_attributesdef.addattribute(atypesym: tsym; atypesymderef: tderef; aparas: tobject);
+ var
+ newattribute: trtti_attribute;
+ begin
+ if not assigned(rtti_attributes) then
+ rtti_attributes := TFPObjectList.Create(True);
+ newattribute := trtti_attribute.Create;
+ newattribute.typesym := atypesym;
+ newattribute.typesymderef := atypesymderef;
+ newattribute.paras:=aparas;
+ rtti_attributes.Add(newattribute);
+ end;
+
+ destructor trtti_attributesdef.destroy;
+ begin
+ rtti_attributes.Free;
+ inherited destroy;
+ end;
+
+ constructor trtti_attributesdef.ppuload(ppufile: tcompilerppufile);
+ var
+ AttrCount: longint;
+ i: integer;
+ atypesymderef : tderef;
+ begin
+ inherited ppuload(attributedef,ppufile);
+ AttrCount := ppufile.getlongint;
+ for i := 0 to AttrCount -1 do
+ begin
+ ppufile.getderef(atypesymderef);
+ addattribute(nil,atypesymderef,nil);
+ end;
+ rtti_attributes := nil;
+ end;
+
+ procedure trtti_attributesdef.ppuwrite(ppufile: tcompilerppufile);
+ var
+ i: longint;
+ begin
+ inherited ppuwrite(ppufile);
+ ppufile.putlongint(get_attribute_count);
+ for i := 0 to get_attribute_count - 1 do
+ begin
+ ppufile.putderef(trtti_attribute(rtti_attributes[i]).typesymderef);
+ end;
+ ppufile.writeentry(ibattributesdef);
+ end;
+
+ function trtti_attributesdef.get_attribute_count: longint;
+ begin
+ if assigned(rtti_attributes) then
+ result := rtti_attributes.Count
+ else
+ result := 0;
+ end;
+
+ procedure trtti_attributesdef.buildderef;
+ var
+ i: longint;
+ begin
+ inherited buildderef;
+ for i := 0 to get_attribute_count -1 do
+ trtti_attribute(rtti_attributes[i]).typesymderef.build(trtti_attribute(rtti_attributes[i]).typesym);
+ end;
+
+ procedure trtti_attributesdef.deref;
+ var
+ i: longint;
+ begin
+ inherited deref;
+ for i := 0 to get_attribute_count -1 do
+ trtti_attribute(rtti_attributes[i]).typesym := ttypesym(trtti_attribute(rtti_attributes[i]).typesymderef.resolve);
+ end;
+
{****************************************************************************
TORDDEF
****************************************************************************}
Index: compiler/ncgrtti.pas
===================================================================
--- compiler/ncgrtti.pas (revision 21375)
+++ compiler/ncgrtti.pas (working copy)
@@ -269,6 +269,8 @@
procedure TRTTIWriter.published_properties_write_rtti_data(propnamelist:TFPHashObjectList;st:tsymtable);
var
i : longint;
+ attributeindex: ShortInt;
+ attributecount: byte;
sym : tsym;
proctypesinfo : byte;
propnameitem : tpropnamelistitem;
@@ -392,7 +394,20 @@
internalerror(200512201);
current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_16bit(propnameitem.propindex));
current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(proctypesinfo));
+
+ if assigned(tpropertysym(sym).rtti_attributesdef) then
+ attributecount:=tpropertysym(sym).rtti_attributesdef.get_attribute_count
+ else
+ attributecount:=0;
+
+ current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(attributecount));
+
write_string(tpropertysym(sym).realname);
+
+ for attributeindex:=0 to attributecount-1 do
+ begin
+ current_asmdata.asmlists[al_rtti].concat(Tai_const.createname(trtti_attribute(tpropertysym(sym).rtti_attributesdef.rtti_attributes[attributeindex]).symbolname,0));
+ end;
maybe_write_align;
end;
end;
Index: compiler/symtable.pas
===================================================================
--- compiler/symtable.pas (revision 21375)
+++ compiler/symtable.pas (working copy)
@@ -435,6 +435,7 @@
ibformaldef : def:=tformaldef.ppuload(ppufile);
ibvariantdef : def:=tvariantdef.ppuload(ppufile);
ibundefineddef : def:=tundefineddef.ppuload(ppufile);
+ ibattributesdef : def:=trtti_attributesdef.ppuload(ppufile);
ibenddefs : break;
ibend : Message(unit_f_ppu_read_error);
else
Index: compiler/utils/ppudump.pp
===================================================================
--- compiler/utils/ppudump.pp (revision 21375)
+++ compiler/utils/ppudump.pp (working copy)
@@ -2624,6 +2624,19 @@
end;
+ ibattributesdef :
+ begin
+ readcommondef('Attributes definition',defoptions);
+ l := getlongint;
+ writeln(space,' Attributes count : ', l);
+ for j := 0 to l-1 do
+ begin
+ writeln(space,'Attribute ',j);
+ write(space,' typedef : ');
+ readderef('');
+ end;
+ end;
+
iberror :
begin
WriteError('!! Error in PPU');
Index: compiler/symsym.pas
===================================================================
--- compiler/symsym.pas (revision 21375)
+++ compiler/symsym.pas (working copy)
@@ -277,6 +277,7 @@
dispid : longint;
propaccesslist: array[tpropaccesslisttypes] of tpropaccesslist;
parast : tsymtable;
+ rtti_attributesdef : trtti_attributesdef;
constructor create(const n : string);
destructor destroy;override;
constructor ppuload(ppufile:tcompilerppufile);
Index: rtl/objpas/typinfo.pp
===================================================================
--- rtl/objpas/typinfo.pp (revision 21375)
+++ rtl/objpas/typinfo.pp (working copy)
@@ -232,11 +232,16 @@
// 6 : true, constant index property
PropProcs : Byte;
+ AttributeCount : byte;
Name : ShortString;
end;
TProcInfoProc = Procedure(PropInfo : PPropInfo) of object;
+ TAttributeProc = function : TObject;
+ PAttributeProcList = ^TAttributeProcList;
+ TAttributeProcList = array[0..255] of TAttributeProc;
+
PPropList = ^TPropList;
TPropList = array[0..65535] of PPropInfo;
@@ -266,8 +271,6 @@
function GetPropList(AClass: TClass; out PropList: PPropList): Integer;
function GetPropList(Instance: TObject; out PropList: PPropList): Integer;
-
-
// Property information routines.
Function IsStoredProp(Instance: TObject;PropInfo : PPropInfo) : Boolean;
Function IsStoredProp(Instance: TObject; const PropName: string): Boolean;
@@ -354,6 +357,9 @@
procedure SetRawInterfaceProp(Instance: TObject; const PropName: string; const Value: Pointer);
procedure SetRawInterfaceProp(Instance: TObject; PropInfo: PPropInfo; const Value: Pointer);
+function GetAttributeProclist(PropInfo: PPropInfo): PAttributeProcList;
+function GetPropAttribute(PropInfo: PPropInfo; AttributeNr: byte): TObject;
+
// Auxiliary routines, which may be useful
Function GetEnumName(TypeInfo : PTypeInfo;Value : Integer) : string;
Function GetEnumValue(TypeInfo : PTypeInfo;const Name : string) : Integer;
@@ -404,7 +410,29 @@
{$endif FPC_REQUIRES_PROPER_ALIGNMENT}
end;
+function GetAttributeProclist(PropInfo: PPropInfo): PAttributeProcList;
+begin
+ if PropInfo^.AttributeCount=0 then
+ result := nil
+ else
+ begin
+ Result:=PAttributeProcList(aligntoptr(pointer(@PropInfo^.Name)+byte(PropInfo^.Name[0])+1));
+ end;
+end;
+function GetPropAttribute(PropInfo: PPropInfo; AttributeNr: byte): TObject;
+var
+ AttributeProcList: PAttributeProcList;
+begin
+ if AttributeNr>=PropInfo^.AttributeCount then
+ result := nil
+ else
+ begin
+ AttributeProcList := GetAttributeProclist(PropInfo);
+ result := AttributeProcList^[AttributeNr]();
+ end;
+end;
+
Function GetEnumName(TypeInfo : PTypeInfo;Value : Integer) : string;
Var PS : PShortString;
@@ -631,7 +659,7 @@
if ShortCompareText(Result^.Name, P) = 0 then
exit;
// skip to next property
- Result:=PPropInfo(aligntoptr(pointer(@Result^.Name)+byte(Result^.Name[0])+1));
+ Result:=PPropInfo(aligntoptr(pointer(@Result^.Name)+byte(Result^.Name[0])+(result^.AttributeCount*SizeOf(TAttributeProc))+1));
end;
// parent class
Typeinfo:=hp^.ParentInfo;
@@ -765,7 +793,7 @@
PropList^[TP^.NameIndex]:=TP;
// Point to TP next propinfo record.
// 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)^+(TP^.AttributeCount*SizeOf(TAttributeProc))+1));
Dec(Count);
end;
TypeInfo:=TD^.Parentinfo;
unit testclassattributesunit;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils;
type
{ TAttribute }
TAttribute = class
private
FValue: string;
public
constructor create(AValue: string);
property Value: string read FValue;
end;
{ THasAttributes }
THasAttributes = class
private
FTestProp: integer;
published
[TAttribute('Value first attribute')]
[TAttribute('Value second attribute')]
property TestProp1: integer read FTestProp write FTestProp;
[TAttribute('Value third attribute')]
property TestProp2: integer read FTestProp write FTestProp;
[TList]
property TestProp3: integer read FTestProp write FTestProp;
end;
implementation
{ TAttribute }
constructor TAttribute.create(AValue: string);
begin
FValue := AValue;
end;
end.
program testclassattributes;
{$mode objfpc}{$H+}
uses
Classes, testclassattributesunit,typinfo;
procedure WritePropInfo(APropInfo: PPropInfo);
var
i: Integer;
AnAttr: TObject;
begin
writeln('Propertyname: ',APropInfo^.Name);
writeln('Attributecount: ',APropInfo^.AttributeCount);
for i := 0 to APropInfo^.AttributeCount-1 do
begin
AnAttr := GetPropAttribute(APropInfo,i);
writeln(' attribute:', AnAttr.ClassName);
if AnAttr is TAttribute then
writeln(' value:', TAttribute(AnAttr).Value);
end;
end;
procedure WriteClassPropInfo(AnObject: TObject);
var
APropList: PPropList;
propcount: integer;
i: integer;
begin
PropCount := GetPropList(AnObject,APropList);
for i := 0 to propcount-1 do
begin
WritePropInfo(APropList^[i]);
end;
end;
var
HasAttributes: THasAttributes;
begin
HasAttributes := THasAttributes.Create;
WriteClassPropInfo(HasAttributes);
HasAttributes.Free;
end.
_______________________________________________
fpc-devel maillist - fpc-devel@lists.freepascal.org
http://lists.freepascal.org/mailman/listinfo/fpc-devel
