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

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 -

.gitattributes

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

compiler/fmodule.pas

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

compiler/globals.pas

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

compiler/globtype.pas

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

compiler/msg/errore.msg

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

compiler/ncgrtti.pas

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

compiler/ngenutil.pas

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

compiler/pdecl.pas

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

compiler/pdecobj.pas

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

compiler/pmodules.pas

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

compiler/psub.pas

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

compiler/ptype.pas

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

compiler/symconst.pas

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

compiler/symcreat.pas

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

compiler/symdef.pas

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

compiler/symsym.pas

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

compiler/symtable.pas

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

packages/rtl-objpas/src/inc/rtti.pp

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

rtl/inc/objpas.inc

@@ -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:='';

rtl/inc/objpash.inc

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

rtl/objpas/typinfo.pp

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

tests/test/tclassattribute1.pp

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

tests/test/tclassattribute10.pp

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

tests/test/tclassattribute2.pp

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

tests/test/tclassattribute3.pp

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

tests/test/tclassattribute4.pp

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

tests/test/tclassattribute5.pp

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

tests/test/tclassattribute6.pp

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

tests/test/tclassattribute7.pp

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

tests/test/tclassattribute8.pp

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

tests/test/tclassattribute9.pp

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