Browse Source

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

joost 13 years ago
parent
commit
6a45402a74

+ 31 - 0
compiler/ncgrtti.pas

@@ -269,6 +269,8 @@ implementation
     procedure TRTTIWriter.published_properties_write_rtti_data(propnamelist:TFPHashObjectList;st:tsymtable);
     procedure TRTTIWriter.published_properties_write_rtti_data(propnamelist:TFPHashObjectList;st:tsymtable);
       var
       var
         i : longint;
         i : longint;
+        attributeindex: ShortInt;
+        attributecount: byte;
         sym : tsym;
         sym : tsym;
         proctypesinfo : byte;
         proctypesinfo : byte;
         propnameitem  : tpropnamelistitem;
         propnameitem  : tpropnamelistitem;
@@ -392,8 +394,22 @@ implementation
                   internalerror(200512201);
                   internalerror(200512201);
                 current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_16bit(propnameitem.propindex));
                 current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_16bit(propnameitem.propindex));
                 current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(proctypesinfo));
                 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);
                 write_string(tpropertysym(sym).realname);
                 maybe_write_align;
                 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;
           end;
       end;
       end;
@@ -767,6 +783,8 @@ implementation
           procedure objectdef_rtti_class_full(def:tobjectdef);
           procedure objectdef_rtti_class_full(def:tobjectdef);
           var
           var
             propnamelist : TFPHashObjectList;
             propnamelist : TFPHashObjectList;
+            attributeindex: ShortInt;
+            attributecount: byte;
           begin
           begin
             { Collect unique property names with nameindex }
             { Collect unique property names with nameindex }
             propnamelist:=TFPHashObjectList.Create;
             propnamelist:=TFPHashObjectList.Create;
@@ -794,10 +812,23 @@ implementation
             { total number of unique properties }
             { total number of unique properties }
             current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_16bit(propnamelist.count));
             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 unit name }
             write_string(current_module.realmodulename^);
             write_string(current_module.realmodulename^);
             maybe_write_align;
             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 }
             { write published properties for this object }
             current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_16bit(published_properties_count(def.symtable)));
             current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_16bit(published_properties_count(def.symtable)));
             maybe_write_align;
             maybe_write_align;

+ 84 - 2
compiler/pdecl.pas

@@ -46,6 +46,8 @@ interface
     procedure threadvar_dec;
     procedure threadvar_dec;
     procedure property_dec;
     procedure property_dec;
     procedure resourcestring_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
 implementation
 
 
@@ -62,7 +64,7 @@ implementation
        symconst,symbase,symtype,symtable,symcreat,paramgr,defutil,
        symconst,symbase,symtype,symtable,symcreat,paramgr,defutil,
        { pass 1 }
        { pass 1 }
        htypechk,
        htypechk,
-       nmat,nadd,ncal,nset,ncnv,ninl,ncon,nld,nflw,nobj,
+       nmat,nadd,ncal,nset,ncnv,ninl,ncon,nld,nflw,nobj,nmem,
        { codegen }
        { codegen }
        ncgutil,ngenutil,
        ncgutil,ngenutil,
        { parser }
        { parser }
@@ -75,6 +77,8 @@ implementation
        cpuinfo
        cpuinfo
        ;
        ;
 
 
+    var
+      current_rtticlassattributesdef : trtti_attributesdef;
 
 
     function readconstant(const orgname:string;const filepos:tfileposinfo):tconstsym;
     function readconstant(const orgname:string;const filepos:tfileposinfo):tconstsym;
       var
       var
@@ -362,6 +366,66 @@ implementation
          consume(_SEMICOLON);
          consume(_SEMICOLON);
       end;
       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 types_dec(in_structure: boolean);
 
 
       procedure finalize_class_external_status(od: tobjectdef);
       procedure finalize_class_external_status(od: tobjectdef);
@@ -411,6 +475,12 @@ implementation
            { fpc generic declaration? }
            { fpc generic declaration? }
            isgeneric:=not(m_delphi in current_settings.modeswitches) and try_to_consume(_GENERIC);
            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;
            typename:=pattern;
            orgtypename:=orgpattern;
            orgtypename:=orgpattern;
            consume(_ID);
            consume(_ID);
@@ -742,6 +812,15 @@ implementation
                         vmtbuilder.free;
                         vmtbuilder.free;
                       end;
                       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
                     { 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
                       name set. We only check this now, because message names can be set
                       during the protocol (interface) mapping. At the same time, set the
                       during the protocol (interface) mapping. At the same time, set the
@@ -784,7 +863,10 @@ implementation
                hdef.typesym:=newtype;
                hdef.typesym:=newtype;
                generictypelist.free;
                generictypelist.free;
              end;
              end;
-         until (token<>_ID) or
+
+           if Assigned(current_rtticlassattributesdef) then
+             internalerror(202105250);
+         until ((token<>_ID) and (token<>_LECKKLAMMER)) or
                (in_structure and
                (in_structure and
                 ((idtoken in [_PRIVATE,_PROTECTED,_PUBLIC,_PUBLISHED,_STRICT]) or
                 ((idtoken in [_PRIVATE,_PROTECTED,_PUBLIC,_PUBLISHED,_STRICT]) or
                  ((m_final_fields in current_settings.modeswitches) and
                  ((m_final_fields in current_settings.modeswitches) and

+ 12 - 0
compiler/pdecobj.pas

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

+ 4 - 4
compiler/pmodules.pas

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

+ 62 - 47
compiler/psub.pas

@@ -31,6 +31,7 @@ interface
       symdef,procinfo,optdfa;
       symdef,procinfo,optdfa;
 
 
     type
     type
+      tcggetcodeblockfunc = function(pd: tprocdef) : tnode;
 
 
       { tcgprocinfo }
       { tcgprocinfo }
 
 
@@ -59,7 +60,7 @@ interface
         procedure resetprocdef;
         procedure resetprocdef;
         procedure add_to_symtablestack;
         procedure add_to_symtablestack;
         procedure remove_from_symtablestack;
         procedure remove_from_symtablestack;
-        procedure parse_body;
+        procedure parse_body(get_code_block_func: tcggetcodeblockfunc);
 
 
         function has_assembler_child : boolean;
         function has_assembler_child : boolean;
       end;
       end;
@@ -76,7 +77,7 @@ interface
     { reads any routine in the implementation, or a non-method routine
     { reads any routine in the implementation, or a non-method routine
       declaration in the interface (depending on whether or not parse_only is
       declaration in the interface (depending on whether or not parse_only is
       true) }
       true) }
-    procedure read_proc(isclassmethod:boolean; usefwpd: tprocdef);
+    procedure read_proc(isclassmethod:boolean; usefwpd: tprocdef; get_code_block_func: tcggetcodeblockfunc);
 
 
     procedure generate_specialization_procs;
     procedure generate_specialization_procs;
 
 
@@ -266,10 +267,44 @@ implementation
           include(current_procinfo.flags,pi_needs_implicit_finally);
           include(current_procinfo.flags,pi_needs_implicit_finally);
       end;
       end;
 
 
-
-    function block(islibrary : boolean) : tnode;
+    procedure init_main_block_syms(block: tnode);
       var
       var
         oldfilepos: tfileposinfo;
         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
       begin
          { parse const,types and vars }
          { parse const,types and vars }
          read_declarations(islibrary);
          read_declarations(islibrary);
@@ -329,37 +364,7 @@ implementation
             begin
             begin
                { parse routine body }
                { parse routine body }
                block:=statement_block(_BEGIN);
                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;
       end;
       end;
 
 
@@ -1583,7 +1588,7 @@ implementation
        end;
        end;
 
 
 
 
-    procedure tcgprocinfo.parse_body;
+    procedure tcgprocinfo.parse_body(get_code_block_func: tcggetcodeblockfunc);
       var
       var
          old_current_procinfo : tprocinfo;
          old_current_procinfo : tprocinfo;
          old_block_type : tblock_type;
          old_block_type : tblock_type;
@@ -1637,8 +1642,17 @@ implementation
              current_scanner.startrecordtokens(procdef.generictokenbuf);
              current_scanner.startrecordtokens(procdef.generictokenbuf);
            end;
            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
          if (df_generic in procdef.defoptions) then
            begin
            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
         Parses the procedure directives, then parses the procedure body, then
         generates the code for it
         generates the code for it
@@ -1786,7 +1800,7 @@ implementation
            tokeninfo^[_FAIL].keyword:=m_all;
            tokeninfo^[_FAIL].keyword:=m_all;
          end;
          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
         { We can't support inlining for procedures that have nested
           procedures because the nested procedures use a fixed offset
           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
         { 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
           into the parse_body routine is not done because of having better file position
           information available }
           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);
           consume(_SEMICOLON);
 
 
         if not isnestedproc then
         if not isnestedproc then
@@ -1834,7 +1849,7 @@ implementation
       end;
       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
         Parses the procedure directives, then parses the procedure body, then
         generates the code for it
         generates the code for it
@@ -1946,7 +1961,7 @@ implementation
          { compile procedure when a body is needed }
          { compile procedure when a body is needed }
          if (pd_body in pdflags) then
          if (pd_body in pdflags) then
            begin
            begin
-             read_proc_body(old_current_procinfo,pd);
+             read_proc_body(old_current_procinfo,pd,get_code_block_func);
            end
            end
          else
          else
            begin
            begin
@@ -2070,7 +2085,7 @@ implementation
               _PROCEDURE,
               _PROCEDURE,
               _OPERATOR:
               _OPERATOR:
                 begin
                 begin
-                  read_proc(is_classdef,nil);
+                  read_proc(is_classdef,nil,nil);
                   is_classdef:=false;
                   is_classdef:=false;
                 end;
                 end;
               _EXPORTS:
               _EXPORTS:
@@ -2105,7 +2120,7 @@ implementation
                       begin
                       begin
                         if is_classdef then
                         if is_classdef then
                           begin
                           begin
-                            read_proc(is_classdef,nil);
+                            read_proc(is_classdef,nil,nil);
                             is_classdef:=false;
                             is_classdef:=false;
                           end
                           end
                         else
                         else
@@ -2153,7 +2168,7 @@ implementation
              _FUNCTION,
              _FUNCTION,
              _PROCEDURE,
              _PROCEDURE,
              _OPERATOR :
              _OPERATOR :
-               read_proc(false,nil);
+               read_proc(false,nil,nil);
              else
              else
                begin
                begin
                  case idtoken of
                  case idtoken of
@@ -2218,7 +2233,7 @@ implementation
                      current_tokenpos:=current_filepos;
                      current_tokenpos:=current_filepos;
                      current_scanner.startreplaytokens(tprocdef(tprocdef(hp).genericdef).generictokenbuf,
                      current_scanner.startreplaytokens(tprocdef(tprocdef(hp).genericdef).generictokenbuf,
                        tprocdef(tprocdef(hp).genericdef).change_endian);
                        tprocdef(tprocdef(hp).genericdef).change_endian);
-                     read_proc_body(nil,tprocdef(hp));
+                     read_proc_body(nil,tprocdef(hp),nil);
                      current_filepos:=oldcurrent_filepos;
                      current_filepos:=oldcurrent_filepos;
                    end
                    end
                  { synthetic routines will be implemented afterwards }
                  { synthetic routines will be implemented afterwards }

+ 47 - 16
compiler/symcreat.pas

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

+ 52 - 1
compiler/symdef.pas

@@ -262,6 +262,21 @@ interface
        end;
        end;
        pvmtentry = ^tvmtentry;
        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 }
        { tobjectdef }
 
 
        tvmcallstatic = (vmcs_default, vmcs_yes, vmcs_no, vmcs_unreachable);
        tvmcallstatic = (vmcs_default, vmcs_yes, vmcs_no, vmcs_unreachable);
@@ -307,6 +322,7 @@ interface
           }
           }
           classref_created_in_current_module : boolean;
           classref_created_in_current_module : boolean;
           objecttype     : tobjecttyp;
           objecttype     : tobjecttyp;
+          rtti_attributesdef : trtti_attributesdef;
           constructor create(ot:tobjecttyp;const n:string;c:tobjectdef);
           constructor create(ot:tobjecttyp;const n:string;c:tobjectdef);
           constructor ppuload(ppufile:tcompilerppufile);
           constructor ppuload(ppufile:tcompilerppufile);
           destructor  destroy;override;
           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_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_jvm_virtual_clmethod,  // Java wrapper for virtual class method
          tsk_field_getter,          // getter for a field (callthrough property is passed in skpara)
          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}
 {$ifdef oldregvars}
@@ -2105,6 +2122,35 @@ implementation
          GetTypeName:='<enumeration type>';
          GetTypeName:='<enumeration type>';
       end;
       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
                                  TORDDEF
@@ -5315,6 +5361,11 @@ implementation
              freemem(vmcallstaticinfo);
              freemem(vmcallstaticinfo);
              vmcallstaticinfo:=nil;
              vmcallstaticinfo:=nil;
            end;
            end;
+         if assigned(rtti_attributesdef) then
+           begin
+             rtti_attributesdef.Free;
+             rtti_attributesdef:=nil;
+           end;
          inherited destroy;
          inherited destroy;
       end;
       end;
 
 

+ 2 - 0
compiler/symsym.pas

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

+ 1 - 0
rtl/inc/objpas.inc

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

+ 68 - 3
rtl/objpas/typinfo.pp

@@ -149,8 +149,10 @@ unit typinfo;
               (ClassType : TClass;
               (ClassType : TClass;
                ParentInfo : PTypeInfo;
                ParentInfo : PTypeInfo;
                PropCount : SmallInt;
                PropCount : SmallInt;
+               AttributeCount : byte;
                UnitName : ShortString
                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:
             tkHelper:
               (HelperParent : PTypeInfo;
               (HelperParent : PTypeInfo;
@@ -232,11 +234,19 @@ unit typinfo;
         //     6 : true, constant index property
         //     6 : true, constant index property
         PropProcs : Byte;
         PropProcs : Byte;
 
 
+        AttributeCount : byte;
         Name : ShortString;
         Name : ShortString;
       end;
       end;
 
 
       TProcInfoProc = Procedure(PropInfo : PPropInfo) of object;
       TProcInfoProc = Procedure(PropInfo : PPropInfo) of object;
 
 
+      TCustomAttribute = class(TObject)
+       end;
+
+      TAttributeProc = function : TObject;
+      PAttributeProcList = ^TAttributeProcList;
+      TAttributeProcList = array[0..255] of TAttributeProc;
+
       PPropList = ^TPropList;
       PPropList = ^TPropList;
       TPropList = array[0..65535] of PPropInfo;
       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; const PropName: string; const Value: Pointer);
 procedure SetRawInterfaceProp(Instance: TObject; PropInfo: PPropInfo; 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
 // Auxiliary routines, which may be useful
 Function GetEnumName(TypeInfo : PTypeInfo;Value : Integer) : string;
 Function GetEnumName(TypeInfo : PTypeInfo;Value : Integer) : string;
 Function GetEnumValue(TypeInfo : PTypeInfo;const Name : string) : Integer;
 Function GetEnumValue(TypeInfo : PTypeInfo;const Name : string) : Integer;
@@ -404,6 +420,51 @@ function aligntoptr(p : pointer) : pointer;inline;
 {$endif FPC_REQUIRES_PROPER_ALIGNMENT}
 {$endif FPC_REQUIRES_PROPER_ALIGNMENT}
    end;
    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;
 Function GetEnumName(TypeInfo : PTypeInfo;Value : Integer) : string;
 
 
@@ -624,6 +685,8 @@ begin
       hp:=GetTypeData(Typeinfo);
       hp:=GetTypeData(Typeinfo);
       // the class info rtti the property rtti follows immediatly
       // the class info rtti the property rtti follows immediatly
       pd:=aligntoptr(pointer(pointer(@hp^.UnitName)+Length(hp^.UnitName)+1));
       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);
       Result:=PPropInfo(@pd^.PropList);
       for i:=1 to pd^.PropCount do
       for i:=1 to pd^.PropCount do
         begin
         begin
@@ -631,7 +694,7 @@ begin
           if ShortCompareText(Result^.Name, P) = 0 then
           if ShortCompareText(Result^.Name, P) = 0 then
             exit;
             exit;
           // skip to next property
           // 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;
         end;
       // parent class
       // parent class
       Typeinfo:=hp^.ParentInfo;
       Typeinfo:=hp^.ParentInfo;
@@ -754,6 +817,8 @@ begin
     TD:=GetTypeData(TypeInfo);
     TD:=GetTypeData(TypeInfo);
     // published properties count for this object
     // published properties count for this object
     TP:=aligntoptr(PPropInfo(aligntoptr((Pointer(@TD^.UnitName)+Length(TD^.UnitName)+1))));
     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)^;
     Count:=PWord(TP)^;
     // Now point TP to first propinfo record.
     // Now point TP to first propinfo record.
     Inc(Pointer(TP),SizeOF(Word));
     Inc(Pointer(TP),SizeOF(Word));
@@ -765,7 +830,7 @@ begin
           PropList^[TP^.NameIndex]:=TP;
           PropList^[TP^.NameIndex]:=TP;
         // Point to TP next propinfo record.
         // Point to TP next propinfo record.
         // Located at Name[Length(Name)+1] !
         // Located at Name[Length(Name)+1] !
-        TP:=aligntoptr(PPropInfo(pointer(@TP^.Name)+PByte(@TP^.Name)^+1));
+        TP:=aligntoptr(PPropInfo(pointer(@TP^.Name)+PByte(@TP^.Name)^+(TP^.AttributeCount*SizeOf(TAttributeProc))+1));
         Dec(Count);
         Dec(Count);
       end;
       end;
     TypeInfo:=TD^.Parentinfo;
     TypeInfo:=TD^.Parentinfo;