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

Reintegration of Custom Attributes branch by Joost van der Sluis with patches reworked by Svetozar Belic [patch 1/3]

Browse Source 
Implemented attributes for class types and properties (based on work by Joost van der Sluis). Added TCustomAttribute - a base class for attributes. Added TUnitInfo record to RTTI. It contains the unit name and unit options (for now only a flag which specifies if the unit contains attributes). Added several tests for attributes.

git-svn-id: trunk@42356 -
This commit is contained in:
svenbarth 2019-07-12 22:04:48 +00:00
parent 28e07f77e4
commit b2932393df
31 changed files with 1126 additions and 72 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
.gitattributes vendored
View File

@ -13139,6 +13139,16 @@ tests/test/tclass6.pp svneol=native#text/plain
tests/test/tclass7.pp svneol=native#text/plain
tests/test/tclass8.pp svneol=native#text/plain
tests/test/tclass9.pp svneol=native#text/pascal
tests/test/tclassattribute1.pp svneol=native#text/pascal
tests/test/tclassattribute10.pp svneol=native#text/pascal
tests/test/tclassattribute2.pp svneol=native#text/pascal
tests/test/tclassattribute3.pp svneol=native#text/pascal
tests/test/tclassattribute4.pp svneol=native#text/pascal
tests/test/tclassattribute5.pp svneol=native#text/pascal
tests/test/tclassattribute6.pp svneol=native#text/pascal
tests/test/tclassattribute7.pp svneol=native#text/pascal
tests/test/tclassattribute8.pp svneol=native#text/pascal
tests/test/tclassattribute9.pp svneol=native#text/pascal
tests/test/tclassinfo1.pp svneol=native#text/pascal
tests/test/tclrprop.pp svneol=native#text/plain
tests/test/tcmov1.pp svneol=native#text/plain

12
compiler/fmodule.pas
View File

@ -44,7 +44,7 @@ interface
uses
cutils,cclasses,cfileutl,
globtype,finput,ogbase,fpkg,
symbase,symsym,
symbase,symsym,symtype,
wpobase,
aasmbase,aasmdata;
@ -68,6 +68,9 @@ interface
);
tmoduleoptions = set of tmoduleoption;
trtti_moduleoption = (rmo_hasattributes);
trtti_moduleoptions = set of trtti_moduleoption;
tlinkcontaineritem=class(tlinkedlistitem)
public
data : TPathStr;
@ -195,6 +198,11 @@ interface
moduleoptions: tmoduleoptions;
deprecatedmsg: pshortstring;
{ contains a reference to the TUnitInfo rtti information for this module }
rttiunitinfo : TAsmSymbol;
rttiunitinfodef : tdef;
rtti_options : trtti_moduleoptions;
{ contains a list of types that are extended by helper types; the key is
the full name of the type and the data is a TFPObjectList of
tobjectdef instances (the helper defs) }
@ -634,6 +642,8 @@ implementation
deprecatedmsg:=nil;
namespace:=nil;
tcinitcode:=nil;
rttiunitinfo:=nil;
rttiunitinfodef:=nil;
_exports:=TLinkedList.Create;
dllscannerinputlist:=TFPHashList.Create;
asmdata:=casmdata.create(modulename);

2
compiler/globals.pas
View File

@ -55,7 +55,7 @@ interface
m_pointer_2_procedure,m_autoderef,m_tp_procvar,m_initfinal,m_default_ansistring,
m_out,m_default_para,m_duplicate_names,m_hintdirective,
m_property,m_default_inline,m_except,m_advanced_records,
m_array_operators];
m_array_operators,m_prefixed_attributes];
delphiunicodemodeswitches = delphimodeswitches + [m_systemcodepage,m_default_unicodestring];
fpcmodeswitches =
[m_fpc,m_string_pchar,m_nested_comment,m_repeat_forward,

6
compiler/globtype.pas
View File

@ -490,7 +490,8 @@ interface
m_isolike_mod, { mod operation as it is required by an iso compatible compiler }
m_array_operators, { use Delphi compatible array operators instead of custom ones ("+") }
m_multi_helpers, { helpers can appear in multiple scopes simultaneously }
m_array2dynarray { regular arrays can be implicitly converted to dynamic arrays }
m_array2dynarray, { regular arrays can be implicitly converted to dynamic arrays }
m_prefixed_attributes { enable attributes that are defined before the type they belong to }
);
tmodeswitches = set of tmodeswitch;
@ -681,7 +682,8 @@ interface
'ISOMOD',
'ARRAYOPERATORS',
'MULTIHELPERS',
'ARRAYTODYNARRAY'
'ARRAYTODYNARRAY',
'PREFIXEDATTRIBUTES'
);

4
compiler/msg/errore.msg
View File

@ -146,7 +146,7 @@ general_t_unitscope=01027_T_Using unit scope: $1
#
# Scanner
#
# 02105 is the last used one
# 02106 is the last used one
#
% \section{Scanner messages.}
% This section lists the messages that the scanner emits. The scanner takes
@ -432,6 +432,8 @@ scan_w_setpeosversion_not_support=02103_W_SETPEOSVERSION is not supported by the
scan_w_setpesubsysversion_not_support=02104_W_SETPESUBSYSVERSION is not supported by the target OS
% The \var{\{\$SETPESUBSYSVERSION\}} directive is not supported by the target OS.
scan_n_changecputype=02105_N_Changed CPU type to be consistent with specified controller
scan_e_unresolved_attribute=02106_E_Unresolved custom attribute: "$1".
% A custom attribute is defined, but there is no identifier to bind it to.
% \end{description}
#
# Parser

92
compiler/ncgrtti.pas
View File

@ -57,6 +57,8 @@ interface
function ref_rtti(def:tdef;rt:trttitype;indirect:boolean;suffix:tsymstr):tasmsymbol;
procedure write_rtti_name(tcb: ttai_typedconstbuilder; def: tdef);
procedure write_rtti_data(tcb: ttai_typedconstbuilder; def:tdef; rt: trttitype);
procedure write_attribute_data(tcb: ttai_typedconstbuilder; def:tdef);
procedure write_unit_info_reference(tcb: ttai_typedconstbuilder);
procedure write_child_rtti_data(def:tdef;rt:trttitype);
procedure write_rtti_reference(tcb: ttai_typedconstbuilder; def: tdef; rt: trttitype);
procedure write_methods(tcb:ttai_typedconstbuilder;st:tsymtable;visibilities:tvisibilities);
@ -72,6 +74,8 @@ interface
function get_rtti_label(def:tdef;rt:trttitype;indirect:boolean):tasmsymbol; inline;
function get_rtti_label_ord2str(def:tdef;rt:trttitype;indirect:boolean):tasmsymbol; inline;
function get_rtti_label_str2ord(def:tdef;rt:trttitype;indirect:boolean):tasmsymbol; inline;
procedure start_write_unit_info;
procedure after_write_unit_info(st: TSymtable);
end;
{ generate RTTI and init tables }
@ -116,6 +120,8 @@ implementation
{ no Delphi-style RTTI for managed platforms }
if target_info.system in systems_managed_vm then
exit;
if current_module.rttiunitinfo=nil then
RTTIWriter.start_write_unit_info;
for i:=0 to st.DefList.Count-1 do
begin
def:=tdef(st.DefList[i]);
@ -170,6 +176,8 @@ implementation
(ds_rtti_table_used in def.defstates) then
RTTIWriter.write_rtti(def,fullrtti);
end;
if st.symtabletype = staticsymtable then
RTTIWriter.after_write_unit_info(st);
end;
@ -753,6 +761,9 @@ implementation
proctypesinfo : byte;
propnameitem : tpropnamelistitem;
propdefname : string;
attridx: ShortInt;
attrcount: byte;
attr: trtti_attribute;
procedure writeaccessproc(pap:tpropaccesslisttypes; shiftvalue : byte; unsetvalue: byte);
var
@ -897,7 +908,23 @@ implementation
internalerror(200512201);
tcb.emit_ord_const(propnameitem.propindex,u16inttype);
tcb.emit_ord_const(proctypesinfo,u8inttype);
{ Write property attribute count }
if assigned(tpropertysym(sym).rtti_attributesdef) then
attrcount:=tpropertysym(sym).rtti_attributesdef.get_attribute_count
else
attrcount:=0;
tcb.emit_ord_const(attrcount,u8inttype);
{ Write property name }
tcb.emit_shortstring_const(tpropertysym(sym).realname);
{ Write property attributes }
for attridx := 0 to attrcount-1 do
begin
attr := trtti_attribute(tpropertysym(sym).rtti_attributesdef.rtti_attributes[attridx]);
tcb.emit_tai(Tai_const.Createname(attr.symbolname,AT_DATA_FORCEINDIRECT,0), cpointerdef.getreusable(ttypesym(attr.typesym).typedef));
end;
tcb.end_anonymous_record;
end;
end;
@ -1551,8 +1578,12 @@ implementation
{ total number of unique properties }
tcb.emit_ord_const(propnamelist.count,u16inttype);
{ write unit name }
tcb.emit_shortstring_const(current_module.realmodulename^);
{ reference to unitinfo with unit-name }
write_unit_info_reference(tcb);
{ TAttributeData }
if rmo_hasattributes in current_module.rtti_options then
write_attribute_data(tcb, def);
{ write published properties for this object }
published_properties_write_rtti_data(tcb,propnamelist,def.symtable);
@ -1715,6 +1746,31 @@ implementation
end;
end;
procedure TRTTIWriter.write_attribute_data(tcb: ttai_typedconstbuilder; def: tdef);
var
count: word;
idx: byte;
attr: trtti_attribute;
begin
if (def.typ = objectdef) and (assigned(tobjectdef(def).rtti_attributesdef)) then
count:=tobjectdef(def).rtti_attributesdef.get_attribute_count
else
count:=0;
tcb.emit_ord_const(count,u16inttype);
if count>0 then
for idx:=0 to count-1 do
begin
attr := trtti_attribute(tobjectdef(def).rtti_attributesdef.rtti_attributes[idx]);
tcb.emit_tai(Tai_const.Createname(attr.symbolname,AT_DATA_FORCEINDIRECT,0), cpointerdef.getreusable(ttypesym(attr.typesym).typedef));
end;
end;
procedure TRTTIWriter.write_unit_info_reference(tcb: ttai_typedconstbuilder);
begin
tcb.emit_tai(Tai_const.Create_sym(current_module.rttiunitinfo), current_module.rttiunitinfodef);
end;
function enumsym_compare_name(item1, item2: pointer): Integer;
var
@ -2098,5 +2154,37 @@ implementation
end;
end;
procedure TRTTIWriter.start_write_unit_info;
var
s : string;
tcb: ttai_typedconstbuilder;
begin
tcb:=ctai_typedconstbuilder.create([tcalo_make_dead_strippable,tcalo_new_section]);
tcb.begin_anonymous_record(make_mangledname('RTTIU',current_module.localsymtable,''), 1, sizeof(pint), 1, 1);
{ write the TRTTIUnitOptions }
tcb.emit_ord_const(byte(longint(current_module.rtti_options)),u8inttype);
{ Write the unit-name }
s := current_module.realmodulename^;
tcb.emit_shortstring_const(current_module.realmodulename^);
current_module.rttiunitinfodef := tcb.end_anonymous_record;
current_module.rttiunitinfo := current_asmdata.DefineAsmSymbol(make_mangledname('RTTIU_',current_module.localsymtable,''),AB_GLOBAL,AT_DATA, current_module.rttiunitinfodef);
current_asmdata.AsmLists[al_rtti].concatList(
tcb.get_final_asmlist(current_module.rttiunitinfo,current_module.rttiunitinfodef,sec_rodata,current_module.rttiunitinfo.name,const_align(sizeof(pint))));
tcb.free;
end;
procedure TRTTIWriter.after_write_unit_info(st: TSymtable);
begin
if current_module.rttiunitinfo<>nil then
begin
{ Write a trailing 255 to mark the end of the symbols-list }
current_asmdata.asmlists[al_rtti].concat(cai_align.Create(sizeof(TConstPtrUInt)));
current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(255));
end;
end;
end.

29
compiler/ngenutil.pas
View File

@ -43,6 +43,8 @@ interface
end;
pinitfinalentry = ^tinitfinalentry;
{ tnodeutils }
tnodeutils = class
class function call_fail_node:tnode; virtual;
class function initialize_data_node(p:tnode; force: boolean):tnode; virtual;
@ -113,6 +115,7 @@ interface
class function create_main_procdef(const name: string; potype:tproctypeoption; ps: tprocsym):tdef; virtual;
class procedure InsertInitFinalTable;
class procedure InsertRTTIUnitList; virtual;
protected
class procedure InsertRuntimeInits(const prefix:string;list:TLinkedList;unitflag:tmoduleflag); virtual;
class procedure InsertRuntimeInitsTablesTable(const prefix,tablename:string;unitflag:tmoduleflag); virtual;
@ -1031,6 +1034,32 @@ implementation
release_init_final_list(entries);
end;
class procedure tnodeutils.InsertRTTIUnitList;
var
hp : tused_unit;
unitinits : TAsmList;
count : longint;
begin
unitinits:=TAsmList.Create;
count:=0;
hp:=tused_unit(usedunits.first);
while assigned(hp) do
begin
unitinits.concat(Tai_const.Createname(make_mangledname('RTTIU_',hp.u.globalsymtable,''),0));
inc(count);
hp:=tused_unit(hp.next);
end;
{ Insert TableCount,InitCount at start }
unitinits.insert(Tai_const.Create_32bit(count));
{ Add to data segment }
maybe_new_object_file(current_asmdata.asmlists[al_globals]);
new_section(current_asmdata.asmlists[al_globals],sec_data,'RTTIUNITLIST',sizeof(pint));
current_asmdata.asmlists[al_globals].concat(Tai_symbol.Createname_global('RTTIUNITLIST',AT_DATA,0, carraydef.getreusable(cansichartype,length('RTTIUNITLIST'))));
current_asmdata.asmlists[al_globals].concatlist(unitinits);
current_asmdata.asmlists[al_globals].concat(Tai_symbol_end.Createname('RTTIUNITLIST'));
unitinits.free;
end;
class procedure tnodeutils.insert_init_final_table(entries:tfplist);
var

164
compiler/pdecl.pas
View File

@ -41,24 +41,27 @@ interface
procedure consts_dec(in_structure, allow_typed_const: boolean;out had_generic:boolean);
procedure label_dec;
procedure type_dec(out had_generic:boolean);
procedure types_dec(in_structure: boolean;out had_generic:boolean);
procedure types_dec(in_structure: boolean;out had_generic:boolean;var rtti_attrs_def: trtti_attributesdef);
procedure var_dec(out had_generic:boolean);
procedure threadvar_dec(out had_generic:boolean);
procedure property_dec;
procedure resourcestring_dec(out had_generic:boolean);
procedure parse_rttiattributes(var rtti_attrs_def: trtti_attributesdef);
procedure add_synthetic_rtti_funtion_declarations(rtti_attrs_def: trtti_attributesdef; name: shortstring);
implementation
uses
SysUtils,
{ common }
cutils,
{ global }
globals,tokens,verbose,widestr,constexp,
systems,aasmdata,fmodule,compinnr,
{ symtable }
symconst,symbase,symtype,symcpu,symcreat,defutil,
symconst,symbase,symtype,symcpu,symcreat,defutil,defcmp,symtable,
{ pass 1 }
ninl,ncon,nobj,ngenutil,
ninl,ncon,nobj,ngenutil,nld,nmem,ncal,
{ parser }
scanner,
pbase,pexpr,ptype,ptconst,pdecsub,pdecvar,pdecobj,pgenutil,pparautl,
@ -69,6 +72,39 @@ implementation
cpuinfo
;
var
system_custom_attribute_def: tobjectdef = nil;
function is_system_custom_attribute_descendant(def:tdef): Boolean;
begin
if system_custom_attribute_def=nil then
system_custom_attribute_def := tobjectdef(search_system_type('TCUSTOMATTRIBUTE').typedef);
Result := def_is_related(def, system_custom_attribute_def);
end;
procedure create_renamed_attr_type_if_needed(hdef: tobjectdef);
const
attrconst = 'attribute';
var
newname : TIDString;
newtypeattr : ttypesym;
i: integer;
begin
if not is_system_custom_attribute_descendant(hdef) then
Exit;
{ Check if the name ends with 'attribute'. }
i := Pos(attrconst, lower(hdef.typename), max(0, length(hdef.typename) - length(attrconst)));
newname:=Copy(hdef.typename, 0, i-1);
if (i > 0) and (length(newname) > 0) then
begin
{ Create a new typesym with 'attribute' removed. }
newtypeattr:=ctypesym.create(newname,hdef,true);
newtypeattr.visibility:=symtablestack.top.currentvisibility;
include(newtypeattr.symoptions,sp_implicitrename);
symtablestack.top.insert(newtypeattr);
end;
end;
function readconstant(const orgname:string;const filepos:tfileposinfo; out nodetype: tnodetype):tconstsym;
var
@ -386,7 +422,100 @@ implementation
consume(_SEMICOLON);
end;
procedure types_dec(in_structure: boolean;out had_generic:boolean);
function find_create_constructor(objdef: tobjectdef): tsymentry;
begin
while assigned(objdef) do
begin
result:=objdef.symtable.Find('CREATE');
if assigned(result) then
exit;
objdef:=objdef.childof;
end;
// A class without a constructor called 'create'?!?
internalerror(2012111101);
end;
procedure parse_rttiattributes(var rtti_attrs_def: trtti_attributesdef);
var
p, p1: tnode;
again: boolean;
od: tobjectdef;
constrSym: tsymentry;
constrProcDef: tprocdef;
typeSym: ttypesym;
oldblock_type: tblock_type;
begin
consume(_LECKKLAMMER);
{ Parse attribute type }
p := factor(false,[ef_type_only]);
if p.nodetype<> errorn then
begin
typeSym := ttypesym(ttypenode(p).typesym);
od := tobjectdef(ttypenode(p).typedef);
if Assigned(od) then
begin
{ Check if the attribute class is related to TCustomAttribute }
if not is_system_custom_attribute_descendant(od) then
incompatibletypes(od, system_custom_attribute_def);
{ Search the tprocdef of the constructor which has to be called. }
constrSym := find_create_constructor(od);
if constrSym.typ<>procsym then
internalerror(2018102301);
constrProcDef:=tprocsym(constrSym).find_procdef_bytype(potype_constructor);
{ Parse the attribute-parameters as if it is a list of parameters from
a call to the constrProcDef constructor in an execution-block. }
p1 := cloadvmtaddrnode.create(ctypenode.create(od));
again:=true;
oldblock_type := block_type;
block_type := bt_body;
do_member_read(od,false,constrProcDef.procsym,p1,again,[], nil);
{ Check the number of parameters }
if (tcallnode(p1).para_count < constrProcDef.minparacount) then
CGMessagePos1(p.fileinfo, parser_e_wrong_parameter_size, od.typename + '.' + constrProcDef.procsym.prettyname);
block_type:=oldblock_type;
{ Add attribute to attribute list which will be added
to the property which is defined next. }
if not assigned(rtti_attrs_def) then
rtti_attrs_def := trtti_attributesdef.create;
rtti_attrs_def.addattribute(typeSym,p1);
Include(current_module.rtti_options, rmo_hasattributes);
end;
end;
p.free;
consume(_RECKKLAMMER);
end;
procedure add_synthetic_rtti_funtion_declarations(rtti_attrs_def: trtti_attributesdef; name: shortstring);
var
i: Integer;
sstate: tscannerstate;
attribute: trtti_attribute;
pd: tprocdef;
begin
name := StringReplace(name, '.', '_', [rfReplaceAll]);
for i := 0 to rtti_attrs_def.get_attribute_count-1 do
begin
attribute := trtti_attribute(rtti_attrs_def.rtti_attributes[i]);
replace_scanner('rtti_class_attributes',sstate);
if str_parse_method_dec('function rtti_'+name+'_'+IntToStr(i)+':'+ attribute.typesym.Name +';',potype_function,false,tabstractrecorddef(ttypesym(attribute.typesym).typedef),pd) then
pd.synthetickind:=tsk_get_rttiattribute
else
internalerror(2012052601);
pd.skpara:=attribute;
attribute.symbolname:=pd.mangledname;
restore_scanner(sstate);
end;
end;
procedure types_dec(in_structure: boolean;out had_generic:boolean;var rtti_attrs_def: trtti_attributesdef);
function determine_generic_def(name:tidstring):tstoreddef;
var
@ -484,6 +613,11 @@ implementation
generictypelist:=nil;
generictokenbuf:=nil;
{ class attribute definitions? }
if m_prefixed_attributes in current_settings.modeswitches then
while token=_LECKKLAMMER do
parse_rttiattributes(rtti_attrs_def);
{ fpc generic declaration? }
if first then
had_generic:=not(m_delphi in current_settings.modeswitches) and try_to_consume(_GENERIC);
@ -888,6 +1022,15 @@ implementation
vmtbuilder.free;
end;
{ If there are attribute-properties available, bind them to
this object }
if assigned(rtti_attrs_def) then
begin
add_synthetic_rtti_funtion_declarations(rtti_attrs_def,hdef.typesym.Name);
tobjectdef(hdef).rtti_attributesdef:=rtti_attrs_def;
rtti_attrs_def := nil;
end;
{ In case of an objcclass, verify that all methods have a message
name set. We only check this now, because message names can be set
during the protocol (interface) mapping. At the same time, set the
@ -903,6 +1046,9 @@ implementation
if is_cppclass(hdef) then
tobjectdef(hdef).finish_cpp_data;
if (m_prefixed_attributes in current_settings.modeswitches) then
create_renamed_attr_type_if_needed(tobjectdef(hdef));
end;
recorddef :
begin
@ -942,7 +1088,10 @@ implementation
else
had_generic:=false;
first:=false;
until (token<>_ID) or
if assigned(rtti_attrs_def) and (rtti_attrs_def.get_attribute_count>0) then
Message1(scan_e_unresolved_attribute,trtti_attribute(rtti_attrs_def.rtti_attributes[0]).typesym.prettyname);
until ((token<>_ID) and (token<>_LECKKLAMMER)) or
(in_structure and
((idtoken in [_PRIVATE,_PROTECTED,_PUBLIC,_PUBLISHED,_STRICT]) or
((m_final_fields in current_settings.modeswitches) and
@ -958,9 +1107,12 @@ implementation
{ reads a type declaration to the symbol table }
procedure type_dec(out had_generic:boolean);
var
rtti_attrs_def: trtti_attributesdef;
begin
consume(_TYPE);
types_dec(false,had_generic);
rtti_attrs_def := nil;
types_dec(false,had_generic,rtti_attrs_def);
end;

30
compiler/pdecobj.pas
View File

@ -39,7 +39,7 @@ interface
function class_destructor_head(astruct: tabstractrecorddef):tprocdef;
function constructor_head:tprocdef;
function destructor_head:tprocdef;
procedure struct_property_dec(is_classproperty:boolean);
procedure struct_property_dec(is_classproperty:boolean;var rtti_attrs_def: trtti_attributesdef);
implementation
@ -162,7 +162,7 @@ implementation
end;
procedure struct_property_dec(is_classproperty:boolean);
procedure struct_property_dec(is_classproperty:boolean;var rtti_attrs_def: trtti_attributesdef);
var
p : tpropertysym;
begin
@ -214,6 +214,13 @@ implementation
Message(parser_e_enumerator_identifier_required);
consume(_SEMICOLON);
end;
if assigned(rtti_attrs_def) then
begin
add_synthetic_rtti_funtion_declarations(rtti_attrs_def,current_structdef.RttiName+'_'+p.RealName);
p.rtti_attributesdef := rtti_attrs_def;
rtti_attrs_def:=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
@ -1056,6 +1063,7 @@ implementation
threadvar_fields : boolean;
vdoptions: tvar_dec_options;
fieldlist: tfpobjectlist;
rtti_attrs_def: trtti_attributesdef;
procedure parse_const;
@ -1153,6 +1161,7 @@ implementation
class_fields:=false;
is_final:=false;
final_fields:=false;
rtti_attrs_def:=nil;
hadgeneric:=false;
threadvar_fields:=false;
object_member_blocktype:=bt_general;
@ -1168,10 +1177,12 @@ implementation
end;
_VAR :
begin
rtti_attrs_def := nil;
parse_var(false);
end;
_CONST:
begin
rtti_attrs_def := nil;
parse_const
end;
_THREADVAR :
@ -1266,6 +1277,7 @@ implementation
begin
if object_member_blocktype=bt_general then
begin
rtti_attrs_def := nil;
if (idtoken=_GENERIC) and
not (m_delphi in current_settings.modeswitches) and
(
@ -1313,7 +1325,7 @@ implementation
end;
end
else if object_member_blocktype=bt_type then
types_dec(true,hadgeneric)
types_dec(true,hadgeneric, rtti_attrs_def)
else if object_member_blocktype=bt_const then
begin
typedconstswritable:=false;
@ -1336,7 +1348,7 @@ implementation
end;
_PROPERTY :
begin
struct_property_dec(is_classdef);
struct_property_dec(is_classdef, rtti_attrs_def);
fields_allowed:=false;
is_classdef:=false;
end;
@ -1349,13 +1361,23 @@ implementation
_CONSTRUCTOR,
_DESTRUCTOR :
begin
rtti_attrs_def := nil;
method_dec(current_structdef,is_classdef,hadgeneric);
fields_allowed:=false;
is_classdef:=false;
hadgeneric:=false;
end;
_LECKKLAMMER:
begin
if m_prefixed_attributes in current_settings.modeswitches then
parse_rttiattributes(rtti_attrs_def)
else
consume(_ID);
end;
_END :
begin
if assigned(rtti_attrs_def) and (rtti_attrs_def.get_attribute_count>0) then
Message1(scan_e_unresolved_attribute,trtti_attribute(rtti_attrs_def.rtti_attributes[0]).typesym.prettyname);
consume(_END);
break;
end;

1
compiler/pmodules.pas
View File

@ -2407,6 +2407,7 @@ type
cnodeutils.InsertWideInitsTablesTable;
cnodeutils.InsertResStrTablesTable;
cnodeutils.InsertMemorySizes;
cnodeutils.InsertRTTIUnitList;
{ Insert symbol to resource info }
cnodeutils.InsertResourceInfo(resources_used);

101
compiler/psub.pas
View File

@ -33,6 +33,8 @@ interface
symdef,procinfo,optdfa;
type
tcggetcodeblockfunc = function(pd: tprocdef) : tnode;
tcgprocinfo = class(tprocinfo)
private
procedure CreateInlineInfo;
@ -64,7 +66,7 @@ interface
procedure resetprocdef;
procedure add_to_symtablestack;
procedure remove_from_symtablestack;
procedure parse_body;
procedure parse_body(get_code_block_func: tcggetcodeblockfunc=nil);
function has_assembler_child : boolean;
procedure set_eh_info; override;
@ -89,7 +91,7 @@ interface
{ reads any routine in the implementation, or a non-method routine
declaration in the interface (depending on whether or not parse_only is
true) }
procedure read_proc(isclassmethod:boolean; usefwpd: tprocdef;isgeneric:boolean);
procedure read_proc(isclassmethod:boolean; usefwpd: tprocdef; isgeneric:boolean; get_code_block_func: tcggetcodeblockfunc = nil);
{ parses only the body of a non nested routine; needs a correctly setup pd }
procedure read_proc_body(pd:tprocdef);
@ -325,10 +327,44 @@ implementation
end;
end;
procedure init_main_block_syms(block: tnode);
var
oldfilepos: tfileposinfo;
begin
{ initialized variables }
if current_procinfo.procdef.localst.symtabletype=localsymtable then
begin
{ initialization of local variables with their initial
values: part of function entry }
oldfilepos:=current_filepos;
current_filepos:=current_procinfo.entrypos;
current_procinfo.procdef.localst.SymList.ForEachCall(@initializevars,block);
current_filepos:=oldfilepos;
end
else if current_procinfo.procdef.localst.symtabletype=staticsymtable then
begin
{ for program and unit initialization code we also need to
initialize the local variables used of Default() }
oldfilepos:=current_filepos;
current_filepos:=current_procinfo.entrypos;
current_procinfo.procdef.localst.SymList.ForEachCall(@initializedefaultvars,block);
current_filepos:=oldfilepos;
end;
if assigned(current_procinfo.procdef.parentfpstruct) then
begin
{ we only do this after the code has been parsed because
otherwise for-loop counters moved to the struct cause
errors; we still do it nevertheless to prevent false
"unused" symbols warnings and to assist debug info
generation }
redirect_parentfpstruct_local_syms(current_procinfo.procdef);
{ finish the parentfpstruct (add padding, ...) }
finish_parentfpstruct(current_procinfo.procdef);
end;
end;
function block(islibrary : boolean) : tnode;
var
oldfilepos: tfileposinfo;
begin
{ parse const,types and vars }
read_declarations(islibrary);
@ -388,37 +424,7 @@ implementation
begin
{ parse routine body }
block:=statement_block(_BEGIN);
{ initialized variables }
if current_procinfo.procdef.localst.symtabletype=localsymtable then
begin
{ initialization of local variables with their initial
values: part of function entry }
oldfilepos:=current_filepos;
current_filepos:=current_procinfo.entrypos;
current_procinfo.procdef.localst.SymList.ForEachCall(@initializevars,block);
current_filepos:=oldfilepos;
end
else if current_procinfo.procdef.localst.symtabletype=staticsymtable then
begin
{ for program and unit initialization code we also need to
initialize the local variables used of Default() }
oldfilepos:=current_filepos;
current_filepos:=current_procinfo.entrypos;
current_procinfo.procdef.localst.SymList.ForEachCall(@initializedefaultvars,block);
current_filepos:=oldfilepos;
end;
if assigned(current_procinfo.procdef.parentfpstruct) then
begin
{ we only do this after the code has been parsed because
otherwise for-loop counters moved to the struct cause
errors; we still do it nevertheless to prevent false
"unused" symbols warnings and to assist debug info
generation }
redirect_parentfpstruct_local_syms(current_procinfo.procdef);
{ finish the parentfpstruct (add padding, ...) }
finish_parentfpstruct(current_procinfo.procdef);
end;
init_main_block_syms(block);
end;
end;
@ -2065,7 +2071,7 @@ implementation
end;
procedure tcgprocinfo.parse_body;
procedure tcgprocinfo.parse_body(get_code_block_func: tcggetcodeblockfunc);
var
old_current_procinfo : tprocinfo;
old_block_type : tblock_type;
@ -2149,8 +2155,17 @@ implementation
current_scanner.startrecordtokens(procdef.generictokenbuf);
end;
{ parse the code ... }
code:=block(current_module.islibrary);
if assigned(get_code_block_func) then
begin
{ generate the code-nodes }
code:=get_code_block_func(procdef);
init_main_block_syms(code);
end
else
begin
{ parse the code ... }
code:=block(current_module.islibrary);
end;
if recordtokens then
begin
@ -2262,7 +2277,7 @@ implementation
end;
procedure read_proc_body(old_current_procinfo:tprocinfo;pd:tprocdef);
procedure read_proc_body(old_current_procinfo:tprocinfo;pd:tprocdef;get_code_block_func: tcggetcodeblockfunc=nil);
{
Parses the procedure directives, then parses the procedure body, then
generates the code for it
@ -2308,7 +2323,7 @@ implementation
tokeninfo^[_FAIL].keyword:=alllanguagemodes;
end;
tcgprocinfo(current_procinfo).parse_body;
tcgprocinfo(current_procinfo).parse_body(get_code_block_func);
{ reset _FAIL as _SELF normal }
if (pd.proctypeoption=potype_constructor) then
@ -2344,7 +2359,7 @@ implementation
assigned(current_procinfo.procdef.owner) and
(current_procinfo.procdef.owner.defowner=current_procinfo.procdef.struct)
)
) then
) and not(assigned(get_code_block_func)) then
consume(_SEMICOLON);
if not isnestedproc then
@ -2368,7 +2383,7 @@ implementation
end;
procedure read_proc(isclassmethod:boolean; usefwpd: tprocdef;isgeneric:boolean);
procedure read_proc(isclassmethod:boolean; usefwpd: tprocdef; isgeneric:boolean; get_code_block_func: tcggetcodeblockfunc);
{
Parses the procedure directives, then parses the procedure body, then
generates the code for it
@ -2527,7 +2542,7 @@ implementation
{ compile procedure when a body is needed }
if (pd_body in pdflags) then
begin
read_proc_body(old_current_procinfo,pd);
read_proc_body(old_current_procinfo,pd, get_code_block_func);
end
else
begin

6
compiler/ptype.pas
View File

@ -677,6 +677,7 @@ implementation
hadgeneric,
fields_allowed, is_classdef, classfields, threadvarfields: boolean;
vdoptions: tvar_dec_options;
rtti_attrs_def: trtti_attributesdef;
begin
{ empty record declaration ? }
if (token=_SEMICOLON) then
@ -697,6 +698,7 @@ implementation
classfields:=false;
threadvarfields:=false;
member_blocktype:=bt_general;
rtti_attrs_def := nil;
repeat
case token of
_TYPE :
@ -857,7 +859,7 @@ implementation
end;
end
else if member_blocktype=bt_type then
types_dec(true,hadgeneric)
types_dec(true,hadgeneric, rtti_attrs_def)
else if member_blocktype=bt_const then
consts_dec(true,true,hadgeneric)
else
@ -869,7 +871,7 @@ implementation
begin
if IsAnonOrLocal then
Message(parser_e_no_properties_in_local_anonymous_records);
struct_property_dec(is_classdef);
struct_property_dec(is_classdef, rtti_attrs_def);
fields_allowed:=false;
is_classdef:=false;
end;

3
compiler/symconst.pas
View File

@ -465,7 +465,8 @@ type
tsk_field_setter, // Setter for a field (callthrough property is passed in skpara)
tsk_block_invoke_procvar, // Call a procvar to invoke inside a block
tsk_interface_wrapper, // Call through to a method from an interface wrapper
tsk_call_no_parameters // Call skpara procedure without passing any parameters nor returning a result
tsk_call_no_parameters, // Call skpara procedure without passing any parameters nor returning a result
tsk_get_rttiattribute // Create and return a TCustomAttribute instance
);
{ synthetic procdef supplementary information (tprocdef.skpara) }

29
compiler/symcreat.pas
View File

@ -1024,6 +1024,33 @@ implementation
setverbosity('W+');
end;
function get_attribute_code_block(pd: tprocdef) : tnode;
var
attribute: trtti_attribute;
load: tloadnode;
statement: tstatementnode;
assignment: tassignmentnode;
begin
attribute:=trtti_attribute(pd.skpara);
load := cloadnode.create(pd.funcretsym,pd.funcretsym.Owner);
assignment := cassignmentnode.create(load,Attribute.constructorcall);
assignment.resultdef := voidtype;
statement := cstatementnode.Create(assignment,nil);
result := cblocknode.create(statement);
result.resultdef := voidtype;
end;
procedure implement_get_attribute(pd: tprocdef);
var
old_parse_only: boolean;
begin
old_parse_only:=parse_only;
parse_only:=false;
read_proc(po_classmethod in pd.procoptions,pd,false,@get_attribute_code_block);
parse_only:=old_parse_only;
end;
procedure add_synthetic_method_implementations_for_st(st: tsymtable);
var
@ -1115,6 +1142,8 @@ implementation
implement_interface_wrapper(pd);
tsk_call_no_parameters:
implement_call_no_parameters(pd);
tsk_get_rttiattribute:
implement_get_attribute(pd);
end;
end;
end;

51
compiler/symdef.pas
View File

@ -392,6 +392,21 @@ interface
end;
pvmtentry = ^tvmtentry;
{ trtti_attributesdef }
trtti_attribute = class
typesym : tsym;
constructorcall : tnode;
symbolname : string;
end;
trtti_attributesdef = class
rtti_attributes : TFPObjectList;
procedure addattribute(atypesym: tsym; constructorcall: tnode);
destructor destroy; override;
function get_attribute_count: longint;
end;
{ tobjectdef }
tvmcallstatic = (vmcs_default, vmcs_yes, vmcs_no, vmcs_unreachable);
@ -438,6 +453,7 @@ interface
}
classref_created_in_current_module : boolean;
objecttype : tobjecttyp;
rtti_attributesdef : trtti_attributesdef;
constructor create(ot:tobjecttyp;const n:string;c:tobjectdef;doregister:boolean);virtual;
constructor ppuload(ppufile:tcompilerppufile);
destructor destroy;override;
@ -2867,6 +2883,36 @@ implementation
GetTypeName:='<enumeration type>';
end;
{****************************************************************************
TRTTI_ATTRIBUTESDEF
****************************************************************************}
procedure trtti_attributesdef.addattribute(atypesym: tsym; constructorcall: tnode);
var
newattribute: trtti_attribute;
begin
if not assigned(rtti_attributes) then
rtti_attributes := TFPObjectList.Create(True);
newattribute := trtti_attribute.Create;
newattribute.typesym := atypesym;
newattribute.constructorcall:=constructorcall;
rtti_attributes.Add(newattribute);
end;
destructor trtti_attributesdef.destroy;
begin
rtti_attributes.Free;
inherited destroy;
end;
function trtti_attributesdef.get_attribute_count: longint;
begin
if assigned(rtti_attributes) then
result := rtti_attributes.Count
else
result := 0;
end;
{****************************************************************************
TORDDEF
@ -6979,6 +7025,11 @@ implementation
freemem(vmcallstaticinfo);
vmcallstaticinfo:=nil;
end;
if assigned(rtti_attributesdef) then
begin
rtti_attributesdef.Free;
rtti_attributesdef:=nil;
end;
inherited destroy;
end;

2
compiler/symsym.pas
View File

@ -352,6 +352,7 @@ interface
dispid : longint;
propaccesslist: array[tpropaccesslisttypes] of tpropaccesslist;
parast : tsymtable;
rtti_attributesdef : trtti_attributesdef;
constructor create(const n : string);virtual;
destructor destroy;override;
constructor ppuload(ppufile:tcompilerppufile);
@ -1375,6 +1376,7 @@ implementation
for pap:=low(tpropaccesslisttypes) to high(tpropaccesslisttypes) do
propaccesslist[pap].free;
parast.free;
rtti_attributesdef.free;
inherited destroy;
end;

4
compiler/symtable.pas
View File

@ -955,10 +955,12 @@ implementation
if (vo_is_funcret in tabstractvarsym(sym).varoptions) then
begin
{ don't warn about the result of constructors }
{ or the synthetic helper functions for class-attributes }
if ((tsym(sym).owner.symtabletype<>localsymtable) or
(tprocdef(tsym(sym).owner.defowner).proctypeoption<>potype_constructor)) and
not (po_noreturn in tprocdef(tsym(sym).owner.defowner).procoptions) and
not(cs_opt_nodedfa in current_settings.optimizerswitches) then
not(cs_opt_nodedfa in current_settings.optimizerswitches) and
(tprocdef(tsym(sym).owner.defowner).synthetickind <> tsk_get_rttiattribute) then
MessagePos(tsym(sym).fileinfo,sym_w_function_result_not_set)
end
else if (tsym(sym).owner.symtabletype=parasymtable) then

39
packages/rtl-objpas/src/inc/rtti.pp
View File

@ -191,6 +191,7 @@ type
protected
function GetHandle: Pointer; virtual; abstract;
public
function GetAttributes: specialize TArray<TCustomAttribute>; virtual; abstract;
property Handle: Pointer read GetHandle;
end;
@ -208,6 +209,8 @@ type
TRttiType = class(TRttiNamedObject)
private
FTypeInfo: PTypeInfo;
FAttributesResolved: boolean;
FAttributes: specialize TArray<TCustomAttribute>;
FMethods: specialize TArray<TRttiMethod>;
function GetAsInstance: TRttiInstanceType;
protected
@ -224,6 +227,7 @@ type
function GetBaseType: TRttiType; virtual;
public
constructor Create(ATypeInfo : PTypeInfo);
function GetAttributes: specialize TArray<TCustomAttribute>; override;
function GetProperties: specialize TArray<TRttiProperty>; virtual;
function GetProperty(const AName: string): TRttiProperty; virtual;
function GetMethods: specialize TArray<TRttiMethod>; virtual;
@ -288,6 +292,8 @@ type
TRttiProperty = class(TRttiMember)
private
FPropInfo: PPropInfo;
FAttributesResolved: boolean;
FAttributes: specialize TArray<TCustomAttribute>;
function GetPropertyType: TRttiType;
function GetIsWritable: boolean;
function GetIsReadable: boolean;
@ -297,6 +303,7 @@ type
function GetHandle: Pointer; override;
public
constructor Create(AParent: TRttiType; APropInfo: PPropInfo);
function GetAttributes: specialize TArray<TCustomAttribute>; override;
function GetValue(Instance: pointer): TValue;
procedure SetValue(Instance: pointer; const AValue: TValue);
property PropertyType: TRttiType read GetPropertyType;
@ -3388,6 +3395,22 @@ begin
FPropInfo := APropInfo;
end;
function TRttiProperty.GetAttributes: specialize TArray<TCustomAttribute>;
var
i: Integer;
begin
if not FAttributesResolved then
begin
setlength(FAttributes,FPropInfo^.AttributeCount);
for i := 0 to FPropInfo^.AttributeCount-1 do
begin
FAttributes[i]:=TCustomAttribute(GetPropAttribute(FPropInfo,i));
end;
FAttributesResolved:=true;
end;
result := FAttributes;
end;
function TRttiProperty.GetValue(Instance: pointer): TValue;
procedure ValueFromBool(value: Int64);
@ -3600,6 +3623,22 @@ begin
FTypeData:=GetTypeData(ATypeInfo);
end;
function TRttiType.GetAttributes: specialize TArray<TCustomAttribute>;
var
i: Integer;
ad: PAttributeData;
begin
if not FAttributesResolved then
begin
ad := GetAttributeData(FTypeInfo);
setlength(FAttributes,ad^.AttributeCount);
for i := 0 to ad^.AttributeCount-1 do
FAttributes[i]:=GetAttribute(ad,i);
FAttributesResolved:=true;
end;
result := FAttributes;
end;
function TRttiType.GetProperties: specialize TArray<TRttiProperty>;
begin
Result := Nil;

8
rtl/inc/objpas.inc
View File

@ -979,11 +979,15 @@
class function TObject.UnitName : {$ifdef FPC_HAS_FEATURE_ANSISTRINGS}ansistring{$else FPC_HAS_FEATURE_ANSISTRINGS}shortstring{$endif FPC_HAS_FEATURE_ANSISTRINGS};
type
// from the typinfo unit
TUnitInfo = packed record
UnitOptions: byte;
UnitName: shortstring;
end;
TClassTypeInfo = {$ifndef FPC_REQUIRES_PROPER_ALIGNMENT}packed{$endif}record
ClassType: TClass;
ParentInfo: Pointer;
PropCount: SmallInt;
UnitName: ShortString;
UnitInfo: ^TUnitInfo;
end;
PClassTypeInfo = ^TClassTypeInfo;
var
@ -997,7 +1001,7 @@
{$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
classtypeinfo:=aligntoqword(classtypeinfo);
{$endif}
result:=classtypeinfo^.UnitName;
result:=classtypeinfo^.UnitInfo^.UnitName;
end
else
result:='';

3
rtl/inc/objpash.inc
View File

@ -428,6 +428,9 @@
{$endif FPC_USE_PSABIEH}
end;
TCustomAttribute = class(TObject)
end;
Const
ExceptProc : TExceptProc = Nil;
RaiseProc : TExceptProc = Nil;

242
rtl/objpas/typinfo.pp
View File

@ -226,7 +226,16 @@ unit TypInfo;
property Field[aIndex: Word]: PVmtFieldEntry read GetField;
end;
TRTTIUnitOption = (rmoHasAttributes);
TRTTIUnitOptions = set of TRTTIUnitOption;
{$PACKRECORDS 1}
PUnitInfo = ^TUnitInfo;
TUnitInfo = packed record
UnitOptions: TRTTIUnitOptions;
UnitName: shortstring;
end;
TTypeInfo = record
Kind : TTypeKind;
Name : ShortString;
@ -562,6 +571,7 @@ unit TypInfo;
{ tkPointer }
property RefType: PTypeInfo read GetRefType;
public
function UnitName: string;
case TTypeKind of
tkUnKnown,tkLString,tkWString,tkVariant,tkUString:
();
@ -608,7 +618,8 @@ unit TypInfo;
(ClassType : TClass;
ParentInfoRef : TypeInfoPtr;
PropCount : SmallInt;
UnitName : ShortString
UnitInfo : PUnitInfo
// AttributeData: TAttributeData;
// here the properties follow as array of TPropInfo
);
tkRecord:
@ -726,6 +737,7 @@ unit TypInfo;
// 6 : true, constant index property
PropProcs : Byte;
AttributeCount : Byte;
Name : ShortString;
property PropType: PTypeInfo read GetPropType;
property Tail: Pointer read GetTail;
@ -734,9 +746,25 @@ unit TypInfo;
TProcInfoProc = Procedure(PropInfo : PPropInfo) of object;
TAttributeProc = function : TCustomAttribute;
PAttributeProcList = ^TAttributeProcList;
TAttributeProcList = array[0..$ffff] of TAttributeProc;
PPropList = ^TPropList;
TPropList = array[0..{$ifdef cpu16}(32768 div sizeof(PPropInfo))-2{$else}65535{$endif}] of PPropInfo;
TAttributeData = record
AttributeCount: word;
AttributesList: TAttributeProcList;
end;
PAttributeData = ^TAttributeData;
PUnitInfoList = ^TUnitInfoList;
TUnitInfoList = record
UnitCount: IntPtr;
Units: array[0..65535] of PUnitInfo;
end;
const
tkString = tkSString;
tkProcedure = tkProcVar; // for compatibility with Delphi
@ -873,6 +901,18 @@ function GetDynArrayProp(Instance: TObject; PropInfo: PPropInfo): Pointer;
procedure SetDynArrayProp(Instance: TObject; const PropName: string; const Value: Pointer);
procedure SetDynArrayProp(Instance: TObject; PropInfo: PPropInfo; const Value: Pointer);
// Extended RTTI
function GetUnitList: PUnitInfoList;
function GetFirstTypeinfoFromUnit(AUnitInfo: PUnitInfo): PTypeInfo;
function GetNextTypeInfo(ATypeInfo: PTypeInfo): PTypeInfo;
function GetAttributeData(TypeInfo: PTypeInfo): PAttributeData;
function GetPropAttributeProclist(PropInfo: PPropInfo): PAttributeProcList;
function GetPropAttribute(PropInfo: PPropInfo; AttributeNr: byte): TObject;
function GetAttribute(AttributeData: PAttributeData; AttributeNr: byte): TCustomAttribute;
// Auxiliary routines, which may be useful
Function GetEnumName(TypeInfo : PTypeInfo;Value : Integer) : string;
Function GetEnumValue(TypeInfo : PTypeInfo;const Name : string) : Integer;
@ -920,6 +960,15 @@ uses rtlconsts;
type
PMethod = ^TMethod;
{ ---------------------------------------------------------------------
TTypeData methods
---------------------------------------------------------------------}
function TTypeData.UnitName: string;
begin
Result := UnitInfo^.UnitName
end;
{ ---------------------------------------------------------------------
Auxiliary methods
---------------------------------------------------------------------}
@ -950,6 +999,187 @@ begin
{$endif}
end;
{$ifdef FPC_HAS_UNIT_RTTI}
var
UnitList: TUnitInfoList; external name 'RTTIUNITLIST';
{$endif FPC_HAS_UNIT_RTTI}
function GetUnitList: PUnitInfoList;
begin
{$ifdef FPC_HAS_UNIT_RTTI}
result := @UnitList;
{$else FPC_HAS_UNIT_RTTI}
result := nil;
{$endif FPC_HAS_UNIT_RTTI}
end;
function GetAttributeData(TypeInfo: PTypeInfo): PAttributeData;
var
TD: PTypeData;
begin
if TypeInfo^.Kind<>tkClass then
result := nil
else
begin
TD := GetTypeData(TypeInfo);
if (rmoHasAttributes in td^.UnitInfo^.UnitOptions) then
Result:=PAttributeData(aligntoptr(pointer(@TD^.UnitInfo)+sizeof(TD^.UnitInfo)))
else
result := nil;
end;
end;
function GetPropData(TypeInfo : PTypeInfo; TypeData: PTypeData) : PPropData;
var
AD: PAttributeData;
begin
if rmoHasAttributes in TypeData^.UnitInfo^.UnitOptions then
begin
AD := GetAttributeData(TypeInfo);
result := PPropData(pointer(AD)+SizeOf(AD^.AttributeCount)+(AD^.AttributeCount*SizeOf(TAttributeProc)));
end
else
result := aligntoptr(pointer(@TypeData^.UnitInfo)+sizeof(TypeData^.UnitInfo));
end;
function GetFirstTypeinfoFromUnit(AUnitInfo: PUnitInfo): PTypeInfo;
begin
result := align(pointer(@AUnitInfo^.UnitName)+1+byte(AUnitInfo^.UnitName[0]), sizeof(Pointer));
end;
function GetNextTypeInfo(ATypeInfo: PTypeInfo): PTypeInfo;
type
TEnumTableMode=(lookup,search);
var
p: pointer;
td: PTypeData;
pd: ppropdata;
i: longint;
fc: longint;
minv,maxv: longint;
EnumTableMode: TEnumTableMode;
count: pword;
begin
td := GetTypeData(ATypeInfo);
p := GetTypeData(ATypeInfo);
case ATypeInfo^.Kind of
tkEnumeration:
begin
p := aligntoptr(p + 1); { OrdType }
minv := PLongInt(p)^;
p := p + SizeOf(LongInt); { MinValue }
maxv := PLongInt(p)^;
p := p + SizeOf(LongInt); { MaxValue }
p := p + SizeOf(PTypeInfo); { basetype }
for i := minv to maxv do
p := p + 1 + pbyte(p)^; { NameList: shortstring length + length of string }
p := p + 1 + pbyte(p)^; { UnitName: shortstring length + length of string }
p := p + 1; { trailing zero }
end;
tkInteger,
tkChar,
tkWChar,
tkBool : begin
p := aligntoptr(p + 1); { OrdType }
p := p + SizeOf(LongInt) + SizeOf(LongInt); { MinValue + MaxValue }
end;
tkSet : begin
p := aligntoptr(p + 1); { OrdType }
p := p + sizeof(PTypeInfo); { CompType }
end;
tkQWord : p := p + SizeOf(QWord) + SizeOf(QWord); { MinQWordValue, MaxQWordValue }
tkInt64 : p := p + SizeOf(Int64) + SizeOf(Int64); { MinInt64Value, MaxInt64Value }
tkSString: p := P + SizeOf(Byte); { MaxLength }
tkArray : begin
p := p + sizeof(Ptrint); { Element size }
p := p + sizeof(PtrInt); { Element count }
p := p + sizeof(pointer); { Element type }
p := p + sizeof(longint); { Variant type }
end;
tkDynArray:begin
p := p + sizeof(Ptrint); { Element size }
p := p + sizeof(PtrInt); { Element type 2 }
p := p + sizeof(longint); { Variant type }
p := p + sizeof(pointer); { Element type }
p := p + 1 + pbyte(p)^; { unitname: shortstring length + length of string }
end;
tkFloat : begin
p := p + sizeof(TFloatType); { Float type }
end;
tkObject,
tkRecord : begin
p := p + 4; { Size }
fc := plongint(p)^;
p := p + 4; { Fieldcount }
p := p + (fc * (sizeof(pointer) + 4)); { Fieldcount * (element type + field offset) }
end;
tkClass : begin
pd := GetPropData(ATypeInfo,td);
p:=@pd^.PropList;
for i:=1 to pd^.PropCount do
p:=aligntoptr(pointer(@ppropinfo(p)^.Name)+byte(ppropinfo(p)^.Name[0])+(ppropinfo(p)^.AttributeCount*SizeOf(TAttributeProc))+1);
end;
tkInterface :
begin
p := aligntoptr(pointer(@td^.IntfUnit)+byte(td^.IntfUnit[0])+1);
p := p+pbyte(p)^+1; { IIDStr }
end;
tkMethod : begin
p := @td^.ParamList[0];
for i := 0 to td^.ParamCount-1 do
begin
p := aligntoptr(p + sizeof(TParamFlags)); { TParamFlags }
p := aligntoptr(p +pbyte(p)^+1); { paramname }
p := aligntoptr(p +pbyte(p)^+1); { typename }
end;
if td^.MethodKind in [mkFunction, mkClassFunction] then
begin
p := aligntoptr(p +pbyte(p)^+1); { resulttype }
p := p + sizeof(PPTypeInfo); { resulttyperef }
end;
p := aligntoptr(p + sizeof(TCallConv)); { cc }
p := p + (td^.ParamCount * sizeof(PPTypeInfo));
end;
end;
result := PTypeInfo(align(p,sizeof(p)));
if PByte(result)^=255 then
result := nil;
end;
function GetPropAttributeProclist(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 := GetPropAttributeProclist(PropInfo);
result := AttributeProcList^[AttributeNr]();
end;
end;
function GetAttribute(AttributeData: PAttributeData; AttributeNr: byte): TCustomAttribute;
var
AttributeProcList: TAttributeProcList;
begin
if (AttributeData=nil) or (AttributeNr>=AttributeData^.AttributeCount) then
result := nil
else
begin
result := AttributeData^.AttributesList[AttributeNr]();
end;
end;
Function GetEnumName(TypeInfo : PTypeInfo;Value : Integer) : string;
@ -1241,7 +1471,7 @@ var
hp : PTypeData;
i : longint;
p : shortstring;
pd : ^TPropData;
pd : PPropData;
begin
P:=PropName; // avoid Ansi<->short conversion in a loop
while Assigned(TypeInfo) do
@ -1249,7 +1479,7 @@ begin
// skip the name
hp:=GetTypeData(Typeinfo);
// the class info rtti the property rtti follows immediatly
pd:=aligntoptr(pointer(pointer(@hp^.UnitName)+Length(hp^.UnitName)+1));
pd := GetPropData(TypeInfo,hp);
Result:=PPropInfo(@pd^.PropList);
for i:=1 to pd^.PropCount do
begin
@ -1257,7 +1487,7 @@ begin
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;
@ -1408,7 +1638,7 @@ begin
repeat
TD:=GetTypeData(TypeInfo);
// published properties count for this object
TP:=aligntoptr(PPropInfo(aligntoptr((Pointer(@TD^.UnitName)+Length(TD^.UnitName)+1))));
TP:=PPropInfo(GetPropData(TypeInfo, TD));
Count:=PWord(TP)^;
// Now point TP to first propinfo record.
Inc(Pointer(TP),SizeOF(Word));
@ -1420,7 +1650,7 @@ begin
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;

43
tests/test/tclassattribute1.pp Normal file
View File

@ -0,0 +1,43 @@
program tclassattribute1;
{$mode objfpc}{$H+}
{$modeswitch prefixedattributes}
uses
typinfo;
type
{ tmyt }
tmyt = class(TCustomAttribute)
constructor create;
end;
type
[Tmyt]
TMyObject = class(TObject)
end;
var
ad: PAttributeData;
AClassAttribute: TCustomAttribute;
{ tmyt }
constructor tmyt.create;
begin
//
end;
begin
ad := GetAttributeData(TMyObject.ClassInfo);
if ad^.AttributeCount<>1 then
halt(1);
AClassAttribute := GetAttribute(ad,0);
if AClassAttribute = nil then
halt(2);
writeln('ok');
end.

34
tests/test/tclassattribute10.pp Normal file
View File

@ -0,0 +1,34 @@
program tclassattribute10;
{$mode objfpc}{$H+}
{$modeswitch prefixedattributes}
uses
typinfo;
type
{ TMyAttr }
TMyAttrAttribute = class(TCustomAttribute)
end;
type
// The attribute should be also accessable without the Attribute suffix.
[TMyAttr]
TMyObject = class(TObject)
end;
var
ad: PAttributeData;
AClassAttribute: TCustomAttribute;
begin
ad := GetAttributeData(TMyObject.ClassInfo);
if ad^.AttributeCount<>1 then
halt(1);
AClassAttribute := GetAttribute(ad,0);
if AClassAttribute = nil then
halt(2);
writeln('ok');
end.

16
tests/test/tclassattribute2.pp Normal file
View File

@ -0,0 +1,16 @@
{ %fail }
program tclassattribute2;
{$mode objfpc}{$H+}
{$modeswitch prefixedattributes}
type
// Delphi XE does compile attributes that are not defined, but ignores them.
// That's clearly a Delphi-bug, so fpc should fail on the following:
[TMyAttributeDoesNotExist]
TMyObject = class(TObject)
end;
begin
end.

22
tests/test/tclassattribute3.pp Normal file
View File

@ -0,0 +1,22 @@
{ %fail }
program tclassattribute3;
{$mode objfpc}{$H+}
{$modeswitch prefixedattributes}
type
{ tmyt }
tmyt = class
constructor create;
end;
// tmyt is not a TCustomAttribute, so this should fail.
[tmyt]
TMyObject = class(TObject)
end;
begin
end.

55
tests/test/tclassattribute4.pp Normal file
View File

@ -0,0 +1,55 @@
program tclassattribute4;
{$mode delphi}
uses
typinfo;
type
{ tmyt }
tmyt = class(TCustomAttribute)
private
FID: integer;
public
constructor create(Id: integer);
end;
type
[Tmyt(924)]
[Tmyt(1425)]
TMyObject = class(TObject)
end;
var
rtd: PAttributeData;
AClassAttribute: tmyt;
{ tmyt }
constructor tmyt.create(Id: integer);
begin
Fid := Id;
end;
begin
rtd := GetAttributeData(TMyObject.ClassInfo);
if rtd^.AttributeCount<>2 then
halt(1);
AClassAttribute := GetAttribute(rtd,1) as tmyt;
if AClassAttribute = nil then
halt(2);
if AClassAttribute.FID<>1425 then
halt(3);
AClassAttribute := GetAttribute(rtd,0) as tmyt;
if AClassAttribute = nil then
halt(2);
if AClassAttribute.FID<>924 then
halt(3);
writeln('ok');
end.

30
tests/test/tclassattribute5.pp Normal file
View File

@ -0,0 +1,30 @@
{ %fail }
program tclassattribute5;
{$mode objfpc}{$H+}
{$modeswitch prefixedattributes}
uses
typinfo;
type
{ tmyt }
tmyt = class(TCustomAttribute)
private
FID: integer;
public
constructor create(Id: integer);
end;
type
// Delphi XE does compile attributes with invalid parameters.
// That's clearly a Delphi-bug, so fpc should fail on the following:
[Tmyt(924,32)]
TMyObject = class(TObject)
end;
begin
end.

51
tests/test/tclassattribute6.pp Normal file
View File

@ -0,0 +1,51 @@
program tclassattribute6;
{$mode objfpc}{$H+}
{$modeswitch prefixedattributes}
uses
typinfo;
type
{ tmyt }
TMyt = class(TCustomAttribute)
constructor create;
end;
type
{ TMyObject }
TMyObject = class(TObject)
private
FInt: integer;
published
[TMyt]
property PublicInt: integer read FInt;
end;
constructor TMyt.create;
begin
end;
var
pi: PPropInfo;
AClassAttribute: TCustomAttribute;
begin
pi := GetPropInfo(TMyObject.ClassInfo,'PublicInt');
if pi^.AttributeCount<>1 then
halt(1);
AClassAttribute := GetPropAttribute(pi,0) as TCustomAttribute;
if AClassAttribute = nil then
halt(2);
writeln('ok');
end.

39
tests/test/tclassattribute7.pp Normal file
View File

@ -0,0 +1,39 @@
{ %fail }
program tclassattribute7;
{$mode objfpc}{$H+}
{$modeswitch prefixedattributes}
uses
typinfo;
type
{ tmyt }
TMyt = class(TCustomAttribute)
constructor create;
end;
type
{ TMyObject }
TMyObject = class(TObject)
private
FInt: integer;
published
// Should fail because there is nothing to bind the custom attribute to.
[TMyt]
end;
constructor TMyt.create;
begin
//
end;
begin
//
end.

37
tests/test/tclassattribute8.pp Normal file
View File

@ -0,0 +1,37 @@
{ %fail }
program tclassattribute8;
{$mode objfpc}{$H+}
{$modeswitch prefixedattributes}
uses
typinfo;
type
{ tmyt }
TMyt = class(TCustomAttribute)
constructor create;
end;
type
{ TMyObject }
[TMyt]
TMyObject = class(TObject)
end;
// Attributes for integers are not allowed, so the following should fail, since
// there is nothing to bind the attribute to.
[TMyt]
int = integer;
constructor TMyt.create;
begin
end;
begin
end.

33
tests/test/tclassattribute9.pp Normal file
View File

@ -0,0 +1,33 @@
program tclassattribute9;
{$mode objfpc}{$H+}
{$modeswitch prefixedattributes}
uses
typinfo;
type
{ tmyt }
// TCustomAttribute without constructor
tmyt = class(TCustomAttribute);
type
[Tmyt]
TMyObject = class(TObject)
end;
var
ad: PAttributeData;
AClassAttribute: TCustomAttribute;
begin
ad := GetAttributeData(TMyObject.ClassInfo);
if ad^.AttributeCount<>1 then
halt(1);
AClassAttribute := GetAttribute(ad,0);
if AClassAttribute = nil then
halt(2);
writeln('ok');
end.