* Implemented class-attributes support.

   When a class-attribute is defined, a hidden function is generated using the 
   mechanism of the symcreat unit. This function returns an instance of the 
   class-attribute type, initialized by calling it's first constructor with
   the given parameters. 
   To be able to do this, the method-generation system in symcreat is extended
   to make it is possible to generate a function based on a tnode-tree
   besides the ability to parse it from a given string. 
   The address of the generated function is stored inside the rtti-information.

git-svn-id: branches/joost/classattributes@21820 -

compiler/ncgrtti.pas

@@ -269,6 +269,8 @@ implementation
     procedure TRTTIWriter.published_properties_write_rtti_data(propnamelist:TFPHashObjectList;st:tsymtable);
       var
         i : longint;
+        attributeindex: ShortInt;
+        attributecount: byte;
         sym : tsym;
         proctypesinfo : byte;
         propnameitem  : tpropnamelistitem;
@@ -392,8 +394,22 @@ implementation
                   internalerror(200512201);
                 current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_16bit(propnameitem.propindex));
                 current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(proctypesinfo));
+
+                if assigned(tpropertysym(sym).rtti_attributesdef) then
+                  attributecount:=tpropertysym(sym).rtti_attributesdef.get_attribute_count
+                else
+                  attributecount:=0;
+
+                current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(attributecount));
+
                 write_string(tpropertysym(sym).realname);
                 maybe_write_align;
+
+                for attributeindex:=0 to attributecount-1 do
+                  begin
+                    current_asmdata.asmlists[al_rtti].concat(Tai_const.createname(trtti_attribute(tpropertysym(sym).rtti_attributesdef.rtti_attributes[attributeindex]).symbolname,0));
+                  end;
+                maybe_write_align;
              end;
           end;
       end;
@@ -767,6 +783,8 @@ implementation
           procedure objectdef_rtti_class_full(def:tobjectdef);
           var
             propnamelist : TFPHashObjectList;
+            attributeindex: ShortInt;
+            attributecount: byte;
           begin
             { Collect unique property names with nameindex }
             propnamelist:=TFPHashObjectList.Create;
@@ -794,10 +812,23 @@ implementation
             { total number of unique properties }
             current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_16bit(propnamelist.count));
 
+            { total amount of class-attributes }
+            if assigned(def.rtti_attributesdef) then
+              attributecount:=def.rtti_attributesdef.get_attribute_count
+            else
+              attributecount:=0;
+            current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(attributecount));
+
             { write unit name }
             write_string(current_module.realmodulename^);
             maybe_write_align;
 
+            for attributeindex:=0 to attributecount-1 do
+              begin
+                current_asmdata.asmlists[al_rtti].concat(Tai_const.createname(trtti_attribute(def.rtti_attributesdef.rtti_attributes[attributeindex]).symbolname,0));
+              end;
+            maybe_write_align;
+
             { write published properties for this object }
             current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_16bit(published_properties_count(def.symtable)));
             maybe_write_align;

compiler/pdecl.pas

@@ -46,6 +46,8 @@ interface
     procedure threadvar_dec;
     procedure property_dec;
     procedure resourcestring_dec;
+    procedure parse_rttiattributes(var rtti_attributes: trtti_attributesdef);
+    procedure add_synthetic_rtti_funtion_declarations(rtti_attributesdef: trtti_attributesdef; name: shortstring);
 
 implementation
 
@@ -62,7 +64,7 @@ implementation
        symconst,symbase,symtype,symtable,symcreat,paramgr,defutil,
        { pass 1 }
        htypechk,
-       nmat,nadd,ncal,nset,ncnv,ninl,ncon,nld,nflw,nobj,
+       nmat,nadd,ncal,nset,ncnv,ninl,ncon,nld,nflw,nobj,nmem,
        { codegen }
        ncgutil,ngenutil,
        { parser }
@@ -75,6 +77,8 @@ implementation
        cpuinfo
        ;
 
+    var
+      current_rtticlassattributesdef : trtti_attributesdef;
 
     function readconstant(const orgname:string;const filepos:tfileposinfo):tconstsym;
       var
@@ -362,6 +366,66 @@ implementation
          consume(_SEMICOLON);
       end;
 
+    procedure parse_rttiattributes(var rtti_attributes: trtti_attributesdef);
+      var
+        p, p1: tnode;
+        paras: tnode;
+        again: boolean;
+        od: tobjectdef;
+        constrpd: tprocdef;
+        typesym: ttypesym;
+        oldblock_type: tblock_type;
+      begin
+        consume(_LECKKLAMMER);
+        { Parse attribute type }
+        p := factor(false,true);
+
+        typesym := ttypesym(ttypenode(p).typesym);
+        od := tobjectdef(ttypenode(p).typedef);
+
+        { Search the tprocdef of the constructor which has to be called. }
+        constrpd := od.find_procdef_bytype(potype_constructor);
+
+        { Parse the attribute-parameters as if it is a list of parameters from
+          a call to the constrpd 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,constrpd.procsym,p1,again,[]);
+        block_type:=oldblock_type;
+
+        { Add attribute to attribute list which will be added
+          to the property which is defined next. }
+        if not assigned(rtti_attributes) then
+          rtti_attributes := trtti_attributesdef.create;
+        rtti_attributes.addattribute(typesym,p1);
+
+        p.free;
+        consume(_RECKKLAMMER);
+      end;
+
+    procedure add_synthetic_rtti_funtion_declarations(rtti_attributesdef: trtti_attributesdef; name: shortstring);
+      var
+        i: Integer;
+        sstate: tscannerstate;
+        attribute: trtti_attribute;
+        pd: tprocdef;
+      begin
+        for i := 0 to rtti_attributesdef.get_attribute_count-1 do
+          begin
+            attribute := trtti_attribute(rtti_attributesdef.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);
 
       procedure finalize_class_external_status(od: tobjectdef);
@@ -411,6 +475,12 @@ implementation
            { fpc generic declaration? }
            isgeneric:=not(m_delphi in current_settings.modeswitches) and try_to_consume(_GENERIC);
 
+           { class attribute definitions? }
+           while token=_LECKKLAMMER do
+             begin
+               parse_rttiattributes(current_rtticlassattributesdef);
+             end;
+
            typename:=pattern;
            orgtypename:=orgpattern;
            consume(_ID);
@@ -742,6 +812,15 @@ implementation
                         vmtbuilder.free;
                       end;
 
+                    { If there are attribute-properties available, bind them to
+                      this object }
+                    if assigned(current_rtticlassattributesdef) then
+                      begin
+                        add_synthetic_rtti_funtion_declarations(current_rtticlassattributesdef,hdef.typesym.Name);
+                        tobjectdef(hdef).rtti_attributesdef:=current_rtticlassattributesdef;
+                        current_rtticlassattributesdef := 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
@@ -784,7 +863,10 @@ implementation
                hdef.typesym:=newtype;
                generictypelist.free;
              end;
-         until (token<>_ID) or
+
+           if Assigned(current_rtticlassattributesdef) then
+             internalerror(202105250);
+         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

compiler/pdecobj.pas

@@ -64,6 +64,7 @@ implementation
 
     var
       current_objectdef : tobjectdef absolute current_structdef;
+      current_rttiattributesdef : trtti_attributesdef;
 
 
     procedure constr_destr_finish_head(pd: tprocdef; const astruct: tabstractrecorddef);
@@ -205,6 +206,12 @@ implementation
               Message(parser_e_enumerator_identifier_required);
             consume(_SEMICOLON);
           end;
+        if assigned(current_rttiattributesdef) then
+          begin
+            add_synthetic_rtti_funtion_declarations(current_rttiattributesdef,current_structdef.RttiName+'_'+p.RealName);
+            p.rtti_attributesdef := current_rttiattributesdef;
+            current_rttiattributesdef:=nil;
+          end;
         { hint directives, these can be separated by semicolons here,
           that needs to be handled here with a loop (PFV) }
         while try_consume_hintdirective(p.symoptions,p.deprecatedmsg) do
@@ -1058,6 +1065,7 @@ implementation
         class_fields:=false;
         is_final:=false;
         final_fields:=false;
+        current_rttiattributesdef:=nil;
         object_member_blocktype:=bt_general;
         repeat
           case token of
@@ -1217,6 +1225,10 @@ implementation
                 fields_allowed:=false;
                 is_classdef:=false;
               end;
+            _LECKKLAMMER:
+              begin
+                parse_rttiattributes(current_rttiattributesdef);
+              end;
             _END :
               begin
                 consume(_END);

compiler/pmodules.pas

@@ -957,7 +957,7 @@ implementation
              { Compile the unit }
              init_procinfo:=create_main_proc(make_mangledname('',current_module.localsymtable,'init'),potype_unitinit,current_module.localsymtable);
              init_procinfo.procdef.aliasnames.insert(make_mangledname('INIT$',current_module.localsymtable,''));
-             init_procinfo.parse_body;
+             init_procinfo.parse_body(nil);
              { save file pos for debuginfo }
              current_module.mainfilepos:=init_procinfo.entrypos;
            end;
@@ -995,7 +995,7 @@ implementation
               { Compile the finalize }
               finalize_procinfo:=create_main_proc(make_mangledname('',current_module.localsymtable,'finalize'),potype_unitfinalize,current_module.localsymtable);
               finalize_procinfo.procdef.aliasnames.insert(make_mangledname('FINALIZE$',current_module.localsymtable,''));
-              finalize_procinfo.parse_body;
+              finalize_procinfo.parse_body(nil);
            end
          else if force_init_final or cnodeutils.force_final then
            finalize_procinfo:=gen_implicit_initfinal(uf_finalize,current_module.localsymtable);
@@ -1948,7 +1948,7 @@ implementation
              main_procinfo:=create_main_proc(mainaliasname,potype_proginit,current_module.localsymtable);
              main_procinfo.procdef.aliasnames.insert('PASCALMAIN');
            end;
-         main_procinfo.parse_body;
+         main_procinfo.parse_body(nil);
          { save file pos for debuginfo }
          current_module.mainfilepos:=main_procinfo.entrypos;
 
@@ -1978,7 +1978,7 @@ implementation
               finalize_procinfo:=create_main_proc(make_mangledname('',current_module.localsymtable,'finalize'),potype_unitfinalize,current_module.localsymtable);
               finalize_procinfo.procdef.aliasnames.insert(make_mangledname('FINALIZE$',current_module.localsymtable,''));
               finalize_procinfo.procdef.aliasnames.insert('PASCALFINALIZE');
-              finalize_procinfo.parse_body;
+              finalize_procinfo.parse_body(nil);
            end
          else
            if force_init_final or cnodeutils.force_final then

compiler/psub.pas

@@ -31,6 +31,7 @@ interface
       symdef,procinfo,optdfa;
 
     type
+      tcggetcodeblockfunc = function(pd: tprocdef) : tnode;
 
       { tcgprocinfo }
 
@@ -59,7 +60,7 @@ interface
         procedure resetprocdef;
         procedure add_to_symtablestack;
         procedure remove_from_symtablestack;
-        procedure parse_body;
+        procedure parse_body(get_code_block_func: tcggetcodeblockfunc);
 
         function has_assembler_child : boolean;
       end;
@@ -76,7 +77,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);
+    procedure read_proc(isclassmethod:boolean; usefwpd: tprocdef; get_code_block_func: tcggetcodeblockfunc);
 
     procedure generate_specialization_procs;
 
@@ -266,10 +267,44 @@ implementation
           include(current_procinfo.flags,pi_needs_implicit_finally);
       end;
 
-
-    function block(islibrary : boolean) : tnode;
+    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;
       begin
          { parse const,types and vars }
          read_declarations(islibrary);
@@ -329,37 +364,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;
 
@@ -1583,7 +1588,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;
@@ -1637,8 +1642,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 (df_generic in procdef.defoptions) then
            begin
@@ -1741,7 +1755,7 @@ implementation
 
 
 
-    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);
       {
         Parses the procedure directives, then parses the procedure body, then
         generates the code for it
@@ -1786,7 +1800,7 @@ implementation
            tokeninfo^[_FAIL].keyword:=m_all;
          end;
 
-        tcgprocinfo(current_procinfo).parse_body;
+        tcgprocinfo(current_procinfo).parse_body(get_code_block_func);
 
         { We can't support inlining for procedures that have nested
           procedures because the nested procedures use a fixed offset
@@ -1825,7 +1839,8 @@ implementation
         { For specialization we didn't record the last semicolon. Moving this parsing
           into the parse_body routine is not done because of having better file position
           information available }
-        if not(df_specialization in current_procinfo.procdef.defoptions) then
+        if not(df_specialization in current_procinfo.procdef.defoptions) and
+           not(assigned(get_code_block_func)) then
           consume(_SEMICOLON);
 
         if not isnestedproc then
@@ -1834,7 +1849,7 @@ implementation
       end;
 
 
-    procedure read_proc(isclassmethod:boolean; usefwpd: tprocdef);
+    procedure read_proc(isclassmethod:boolean; usefwpd: tprocdef; get_code_block_func: tcggetcodeblockfunc);
       {
         Parses the procedure directives, then parses the procedure body, then
         generates the code for it
@@ -1946,7 +1961,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
@@ -2070,7 +2085,7 @@ implementation
               _PROCEDURE,
               _OPERATOR:
                 begin
-                  read_proc(is_classdef,nil);
+                  read_proc(is_classdef,nil,nil);
                   is_classdef:=false;
                 end;
               _EXPORTS:
@@ -2105,7 +2120,7 @@ implementation
                       begin
                         if is_classdef then
                           begin
-                            read_proc(is_classdef,nil);
+                            read_proc(is_classdef,nil,nil);
                             is_classdef:=false;
                           end
                         else
@@ -2153,7 +2168,7 @@ implementation
              _FUNCTION,
              _PROCEDURE,
              _OPERATOR :
-               read_proc(false,nil);
+               read_proc(false,nil,nil);
              else
                begin
                  case idtoken of
@@ -2218,7 +2233,7 @@ implementation
                      current_tokenpos:=current_filepos;
                      current_scanner.startreplaytokens(tprocdef(tprocdef(hp).genericdef).generictokenbuf,
                        tprocdef(tprocdef(hp).genericdef).change_endian);
-                     read_proc_body(nil,tprocdef(hp));
+                     read_proc_body(nil,tprocdef(hp),nil);
                      current_filepos:=oldcurrent_filepos;
                    end
                  { synthetic routines will be implemented afterwards }

compiler/symcreat.pas

@@ -29,6 +29,8 @@ interface
   uses
     finput,tokens,scanner,globtype,
     aasmdata,
+    node,
+    psub,
     symconst,symbase,symtype,symdef,symsym;
 
 
@@ -62,7 +64,7 @@ interface
         * save the scanner state before calling this routine, and restore when done.
         * the code *must* be written in objfpc style
   }
-  function str_parse_method_impl(str: ansistring; usefwpd: tprocdef; is_classdef: boolean):boolean;
+  function str_parse_method_impl(str: ansistring; get_code_block_func: tcggetcodeblockfunc; usefwpd: tprocdef; is_classdef: boolean):boolean;
 
   { parses a typed constant assignment to ssym
 
@@ -120,11 +122,11 @@ implementation
   uses
     cutils,cclasses,globals,verbose,systems,comphook,fmodule,
     symtable,defutil,
-    pbase,pdecobj,pdecsub,psub,ptconst,
+    pbase,pdecobj,pdecsub,ptconst,
 {$ifdef jvm}
     pjvm,jvmdef,
 {$endif jvm}
-    node,nbas,nld,nmem,ngenutil,
+    nbas,nld,nmem,ngenutil,
     defcmp,
     paramgr;
 
@@ -216,7 +218,7 @@ implementation
     end;
 
 
-  function str_parse_method_impl(str: ansistring; usefwpd: tprocdef; is_classdef: boolean):boolean;
+  function str_parse_method_impl(str: ansistring; get_code_block_func: tcggetcodeblockfunc; usefwpd: tprocdef; is_classdef: boolean):boolean;
      var
        oldparse_only: boolean;
        tmpstr: ansistring;
@@ -242,7 +244,7 @@ implementation
       current_scanner.substitutemacro('meth_impl_macro',@str[1],length(str),current_scanner.line_no,current_scanner.inputfile.ref_index);
       current_scanner.readtoken(false);
       { and parse it... }
-      read_proc(is_classdef,usefwpd);
+      read_proc(is_classdef,usefwpd,get_code_block_func);
       parse_only:=oldparse_only;
       { remove the temporary macro input file again }
       current_scanner.closeinputfile;
@@ -355,7 +357,7 @@ implementation
          not is_void(pd.returndef) then
         str:=str+'result:=';
       str:=str+'inherited end;';
-      str_parse_method_impl(str,pd,isclassmethod);
+      str_parse_method_impl(str,nil,pd,isclassmethod);
     end;
 
 
@@ -399,7 +401,7 @@ implementation
             end;
         end;
       str:=str+'end;';
-      str_parse_method_impl(str,pd,false);
+      str_parse_method_impl(str,nil,pd,false);
     end;
 
 
@@ -431,7 +433,7 @@ implementation
             end;
         end;
       str:=str+'end;';
-      str_parse_method_impl(str,pd,false);
+      str_parse_method_impl(str,nil,pd,false);
     end;
 
 
@@ -464,7 +466,7 @@ implementation
             end;
         end;
       str:=str+'end;';
-      str_parse_method_impl(str,pd,false);
+      str_parse_method_impl(str,nil,pd,false);
     end;
 
   procedure implement_empty(pd: tprocdef);
@@ -476,7 +478,7 @@ implementation
         (po_classmethod in pd.procoptions) and
         not(pd.proctypeoption in [potype_constructor,potype_destructor]);
       str:='begin end;';
-      str_parse_method_impl(str,pd,isclassmethod);
+      str_parse_method_impl(str,nil,pd,isclassmethod);
     end;
 
 
@@ -518,7 +520,7 @@ implementation
       str:=str+callpd.procsym.realname+'(';
       addvisibibleparameters(str,pd);
       str:=str+') end;';
-      str_parse_method_impl(str,pd,isclassmethod);
+      str_parse_method_impl(str,nil,pd,isclassmethod);
     end;
 
 
@@ -837,7 +839,7 @@ implementation
     begin
       callthroughprop:=tpropertysym(pd.skpara);
       str:='begin result:='+callthroughprop.realname+'; end;';
-      str_parse_method_impl(str,pd,po_classmethod in pd.procoptions)
+      str_parse_method_impl(str,nil,pd,po_classmethod in pd.procoptions)
     end;
 
 
@@ -848,7 +850,35 @@ implementation
     begin
       callthroughprop:=tpropertysym(pd.skpara);
       str:='begin '+callthroughprop.realname+':=__fpc_newval__; end;';
-      str_parse_method_impl(str,pd,po_classmethod in pd.procoptions)
+      str_parse_method_impl(str,nil,pd,po_classmethod in pd.procoptions)
+    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,@get_attribute_code_block);
+      parse_only:=old_parse_only;
     end;
 
 
@@ -922,6 +952,8 @@ implementation
               implement_field_getter(pd);
             tsk_field_setter:
               implement_field_setter(pd);
+            tsk_get_rttiattribute:
+              implement_get_attribute(pd)
             else
               internalerror(2011032801);
           end;
@@ -935,9 +967,6 @@ implementation
       def: tdef;
       sstate: tscannerstate;
     begin
-      { only necessary for the JVM target currently }
-      if not (target_info.system in systems_jvm) then
-        exit;
       replace_scanner('synthetic_impl',sstate);
       add_synthetic_method_implementations_for_st(st);
       for i:=0 to st.deflist.count-1 do
@@ -948,6 +977,8 @@ implementation
              { not true for the "main" procedure, whose localsymtable is the staticsymtable }
              (tprocdef(def).localst.symtabletype=localsymtable) then
             add_synthetic_method_implementations(tprocdef(def).localst)
+          else if (def.typ=objectdef) then
+            add_synthetic_method_implementations(tobjectdef(def).symtable)
           else if (is_javaclass(def) and
               not(oo_is_external in tobjectdef(def).objectoptions)) or
               (def.typ=recorddef) then

compiler/symdef.pas

@@ -262,6 +262,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);
@@ -307,6 +322,7 @@ interface
           }
           classref_created_in_current_module : boolean;
           objecttype     : tobjecttyp;
+          rtti_attributesdef : trtti_attributesdef;
           constructor create(ot:tobjecttyp;const n:string;c:tobjectdef);
           constructor ppuload(ppufile:tcompilerppufile);
           destructor  destroy;override;
@@ -540,7 +556,8 @@ interface
          tsk_jvm_procvar_intconstr, // Java procvar class constructor that accepts an interface instance for easy Java interoperation
          tsk_jvm_virtual_clmethod,  // Java wrapper for virtual class method
          tsk_field_getter,          // getter for a field (callthrough property is passed in skpara)
-         tsk_field_setter           // Setter for a field (callthrough property is passed in skpara)
+         tsk_field_setter,          // Setter for a field (callthrough property is passed in skpara)
+         tsk_get_rttiattribute      // Create and return a TCustomAttribute instance
        );
 
 {$ifdef oldregvars}
@@ -2105,6 +2122,35 @@ 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
@@ -5315,6 +5361,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

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

rtl/inc/objpas.inc

@@ -935,6 +935,7 @@
             ClassType: TClass;
             ParentInfo: Pointer;
             PropCount: SmallInt;
+            AttributeCount : byte;
             UnitName: ShortString;
           end;
           PClassTypeInfo = ^TClassTypeInfo;

rtl/objpas/typinfo.pp

@@ -149,8 +149,10 @@ unit typinfo;
               (ClassType : TClass;
                ParentInfo : PTypeInfo;
                PropCount : SmallInt;
+               AttributeCount : byte;
                UnitName : ShortString
-               // here the properties follow as array of TPropInfo
+               // here the attributes follow as array of TAttributeProc
+               // followed by the properties as array of TPropInfo
               );
             tkHelper:
               (HelperParent : PTypeInfo;
@@ -232,11 +234,19 @@ unit typinfo;
         //     6 : true, constant index property
         PropProcs : Byte;
 
+        AttributeCount : byte;
         Name : ShortString;
       end;
 
       TProcInfoProc = Procedure(PropInfo : PPropInfo) of object;
 
+      TCustomAttribute = class(TObject)
+       end;
+
+      TAttributeProc = function : TObject;
+      PAttributeProcList = ^TAttributeProcList;
+      TAttributeProcList = array[0..255] of TAttributeProc;
+
       PPropList = ^TPropList;
       TPropList = array[0..65535] of PPropInfo;
 
@@ -354,6 +364,12 @@ function GetRawInterfaceProp(Instance: TObject; PropInfo: PPropInfo): Pointer;
 procedure SetRawInterfaceProp(Instance: TObject; const PropName: string; const Value: Pointer);
 procedure SetRawInterfaceProp(Instance: TObject; PropInfo: PPropInfo; const Value: Pointer);
 
+function GetPropAttributeProclist(PropInfo: PPropInfo): PAttributeProcList;
+function GetPropAttribute(PropInfo: PPropInfo; AttributeNr: byte): TObject;
+
+function GetClassAttributeProclist(TypeData: PTypeData): PAttributeProcList;
+function GetClassAttribute(TypeData: PTypeData; AttributeNr: byte): TObject;
+
 // Auxiliary routines, which may be useful
 Function GetEnumName(TypeInfo : PTypeInfo;Value : Integer) : string;
 Function GetEnumValue(TypeInfo : PTypeInfo;const Name : string) : Integer;
@@ -404,6 +420,51 @@ function aligntoptr(p : pointer) : pointer;inline;
 {$endif FPC_REQUIRES_PROPER_ALIGNMENT}
    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 GetClassAttributeProclist(TypeData: PTypeData): PAttributeProcList;
+begin
+  if TypeData^.AttributeCount=0 then
+    result := nil
+  else
+    begin
+      Result:=PAttributeProcList(aligntoptr(pointer(@TypeData^.UnitName)+byte(TypeData^.UnitName[0])+1));
+    end;
+end;
+
+function GetClassAttribute(TypeData: PTypeData; AttributeNr: byte): TObject;
+var
+  AttributeProcList: PAttributeProcList;
+begin
+  if AttributeNr>=TypeData^.AttributeCount then
+    result := nil
+  else
+    begin
+      AttributeProcList := GetClassAttributeProclist(TypeData);
+      result := AttributeProcList^[AttributeNr]();
+    end;
+end;
 
 Function GetEnumName(TypeInfo : PTypeInfo;Value : Integer) : string;
 
@@ -624,6 +685,8 @@ begin
       hp:=GetTypeData(Typeinfo);
       // the class info rtti the property rtti follows immediatly
       pd:=aligntoptr(pointer(pointer(@hp^.UnitName)+Length(hp^.UnitName)+1));
+      // also skip the attribute-information
+      pd:=aligntoptr(pointer(pd)+(hp^.AttributeCount*sizeof(TAttributeProc)));
       Result:=PPropInfo(@pd^.PropList);
       for i:=1 to pd^.PropCount do
         begin
@@ -631,7 +694,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;
@@ -754,6 +817,8 @@ begin
     TD:=GetTypeData(TypeInfo);
     // published properties count for this object
     TP:=aligntoptr(PPropInfo(aligntoptr((Pointer(@TD^.UnitName)+Length(TD^.UnitName)+1))));
+    // skip the attribute-info if available
+    TP:=aligntoptr(pointer(TP)+(TD^.AttributeCount*sizeof(TAttributeProc)));
     Count:=PWord(TP)^;
     // Now point TP to first propinfo record.
     Inc(Pointer(TP),SizeOF(Word));
@@ -765,7 +830,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;