* store attribute information in PPU; this is less important for the compiler, but more for e.g. Lazarus when dealing with binary only units

* increase ppu version
+ added test
* adjust ppudump to handle attributes as well
ToDo: output parameter nodes as well

git-svn-id: trunk@42401 -

.gitattributes

@@ -13210,6 +13210,7 @@ tests/test/tcustomattr10.pp svneol=native#text/pascal
 tests/test/tcustomattr11.pp svneol=native#text/pascal
 tests/test/tcustomattr12.pp svneol=native#text/pascal
 tests/test/tcustomattr13.pp svneol=native#text/pascal
+tests/test/tcustomattr14.pp svneol=native#text/pascal
 tests/test/tcustomattr2.pp svneol=native#text/pascal
 tests/test/tcustomattr3.pp svneol=native#text/pascal
 tests/test/tcustomattr4.pp svneol=native#text/pascal
@@ -14222,6 +14223,8 @@ tests/test/tx64ccnv.pp svneol=native#text/plain
 tests/test/uabstrcl.pp svneol=native#text/plain
 tests/test/uchlp12.pp svneol=native#text/pascal
 tests/test/uchlp18.pp svneol=native#text/pascal
+tests/test/ucustomattr14a.pp svneol=native#text/pascal
+tests/test/ucustomattr14b.pp svneol=native#text/pascal
 tests/test/udots.moredots.unit7.pp svneol=native#text/pascal
 tests/test/udots.moredots.unit8.pp svneol=native#text/pascal
 tests/test/udots.udots.unit4.pp svneol=native#text/pascal

compiler/ppu.pas

@@ -50,7 +50,7 @@ const
   CurrentPPUVersion = 207;
   { for any other changes to the ppu format, increase this version number
     (it's a cardinal) }
-  CurrentPPULongVersion = 2;
+  CurrentPPULongVersion = 3;
 
 { unit flags }
   uf_big_endian          = $000004;

compiler/symdef.pas

@@ -62,11 +62,20 @@ interface
 
        trtti_attribute = class
           typesym         : tsym;
+          typesymderef    : tderef;
           typeconstr      : tdef;
+          typeconstrderef : tderef;
+          { these two are not stored in PPU }
           constructorcall : tnode;
           constructorpd   : tdef;
           paras           : array of tnode;
+          constructor ppuload(ppufile:tcompilerppufile);
+          procedure ppuwrite(ppufile:tcompilerppufile);
+          procedure ppuload_subentries(ppufile:tcompilerppufile);
+          procedure ppuwrite_subentries(ppufile:tcompilerppufile);
           destructor destroy;override;
+          procedure buildderef;
+          procedure deref;
        end;
 
        trtti_attribute_list = class
@@ -75,8 +84,16 @@ interface
           is_bound : Boolean;
           class procedure bind(var dangling,owned:trtti_attribute_list);
           procedure addattribute(atypesym:tsym;typeconstr:tdef;constructorcall:tnode;constref paras:array of tnode);
+          procedure addattribute(attr:trtti_attribute);
           destructor destroy; override;
           function get_attribute_count:longint;
+          procedure buildderef;
+          procedure deref;
+
+          class function ppuload(ppufile:tcompilerppufile):trtti_attribute_list;
+          class procedure ppuwrite(attrlist:trtti_attribute_list;ppufile:tcompilerppufile);
+          class procedure ppuload_subentries(attrlist:trtti_attribute_list;ppufile:tcompilerppufile);
+          class procedure ppuwrite_subentries(attrlist:trtti_attribute_list;ppufile:tcompilerppufile);
        end;
 
        { tstoreddef }
@@ -1965,6 +1982,7 @@ implementation
            end;
         if df_specialization in defoptions then
           ppufile.getderef(genericdefderef);
+        rtti_attribute_list:=trtti_attribute_list.ppuload(ppufile);
       end;
 
 
@@ -2138,18 +2156,19 @@ implementation
         ppufile.do_crc:=oldintfcrc;
         if df_specialization in defoptions then
           ppufile.putderef(genericdefderef);
+        trtti_attribute_list.ppuwrite(rtti_attribute_list,ppufile);
       end;
 
 
     procedure tstoreddef.ppuload_subentries(ppufile: tcompilerppufile);
       begin
-        { by default: do nothing }
+        trtti_attribute_list.ppuload_subentries(rtti_attribute_list,ppufile);
       end;
 
 
     procedure tstoreddef.ppuwrite_subentries(ppufile: tcompilerppufile);
       begin
-        { by default: do nothing }
+        trtti_attribute_list.ppuwrite_subentries(rtti_attribute_list,ppufile);
       end;
 
 
@@ -2163,6 +2182,8 @@ implementation
           register_def;
         typesymderef.build(typesym);
         genericdefderef.build(genericdef);
+        if assigned(rtti_attribute_list) then
+          rtti_attribute_list.buildderef;
         if assigned(genconstraintdata) then
           genconstraintdata.buildderef;
         if assigned(genericparas) then
@@ -2193,6 +2214,8 @@ implementation
         typesym:=ttypesym(typesymderef.resolve);
         if df_specialization in defoptions then
           genericdef:=tstoreddef(genericdefderef.resolve);
+        if assigned(rtti_attribute_list) then
+          rtti_attribute_list.deref;
         if assigned(genconstraintdata) then
           genconstraintdata.deref;
         if assigned(genericparas) then
@@ -2913,6 +2936,35 @@ implementation
                              TRTTI_ATTRIBUTE_LIST
 ****************************************************************************}
 
+    constructor trtti_attribute.ppuload(ppufile: tcompilerppufile);
+      begin
+        ppufile.getderef(typesymderef);
+        ppufile.getderef(typeconstrderef);
+        setlength(paras,ppufile.getlongint);
+      end;
+
+    procedure trtti_attribute.ppuwrite(ppufile: tcompilerppufile);
+      begin
+        ppufile.putderef(typesymderef);
+        ppufile.putderef(typeconstrderef);
+        ppufile.putlongint(length(paras));
+      end;
+
+    procedure trtti_attribute.ppuload_subentries(ppufile: tcompilerppufile);
+      var
+        i : sizeint;
+      begin
+        for i:=0 to high(paras) do
+          paras[i]:=ppuloadnodetree(ppufile);
+      end;
+
+    procedure trtti_attribute.ppuwrite_subentries(ppufile: tcompilerppufile);
+      var
+        i : sizeint;
+      begin
+        for i:=0 to high(paras) do
+          ppuwritenodetree(ppufile,paras[i]);
+      end;
 
     destructor trtti_attribute.destroy;
       var
@@ -2924,6 +2976,26 @@ implementation
         inherited destroy;
       end;
 
+    procedure trtti_attribute.buildderef;
+      var
+        i : sizeint;
+      begin
+        typesymderef.build(typesym);
+        typeconstrderef.build(typeconstr);
+        for i:=0 to high(paras) do
+          paras[i].buildderefimpl;
+      end;
+
+    procedure trtti_attribute.deref;
+      var
+        i : sizeint;
+      begin
+        typesym:=tsym(typesymderef.resolve);
+        typeconstr:=tdef(typeconstrderef.resolve);
+        for i:=0 to high(paras) do
+          paras[i].derefimpl;
+      end;
+
     class procedure trtti_attribute_list.bind(var dangling,owned:trtti_attribute_list);
       begin
         if assigned(owned) then
@@ -2955,6 +3027,13 @@ implementation
         rtti_attributes.Add(newattribute);
       end;
 
+    procedure trtti_attribute_list.addattribute(attr:trtti_attribute);
+      begin
+        if not assigned(rtti_attributes) then
+          rtti_attributes:=TFPObjectList.Create(true);
+        rtti_attributes.add(attr);
+      end;
+
     destructor trtti_attribute_list.destroy;
       var
         i : longint;
@@ -2976,6 +3055,79 @@ implementation
           result:=0;
       end;
 
+    procedure trtti_attribute_list.buildderef;
+      var
+        i : sizeint;
+      begin
+        if not assigned(rtti_attributes) then
+          exit;
+        for i:=0 to rtti_attributes.count-1 do
+          trtti_attribute(rtti_attributes[i]).buildderef;
+      end;
+
+    procedure trtti_attribute_list.deref;
+      var
+        i : sizeint;
+      begin
+        if not assigned(rtti_attributes) then
+          exit;
+        for i:=0 to rtti_attributes.count-1 do
+          trtti_attribute(rtti_attributes[i]).deref;
+      end;
+
+    class procedure trtti_attribute_list.ppuload_subentries(attrlist:trtti_attribute_list;ppufile:tcompilerppufile);
+      var
+        i : sizeint;
+      begin
+        if assigned(attrlist) then
+          begin
+            if not assigned(attrlist.rtti_attributes) then
+              internalerror(2019071101);
+            for i:=0 to attrlist.rtti_attributes.count-1 do
+              trtti_attribute(attrlist.rtti_attributes[i]).ppuload_subentries(ppufile);
+          end;
+      end;
+
+    class procedure trtti_attribute_list.ppuwrite_subentries(attrlist:trtti_attribute_list;ppufile:tcompilerppufile);
+      var
+        i : sizeint;
+      begin
+        if assigned(attrlist) and assigned(attrlist.rtti_attributes) then
+          begin
+            for i:=0 to attrlist.rtti_attributes.count-1 do
+              trtti_attribute(attrlist.rtti_attributes[i]).ppuwrite_subentries(ppufile);
+          end;
+      end;
+
+    class function trtti_attribute_list.ppuload(ppufile:tcompilerppufile):trtti_attribute_list;
+      var
+        cnt,i : longint;
+      begin
+        cnt:=ppufile.getlongint;
+        if cnt>0 then
+          begin
+            result:=trtti_attribute_list.create;
+            for i:=0 to cnt-1 do
+              result.addattribute(trtti_attribute.ppuload(ppufile));
+          end
+        else
+          result:=nil;
+      end;
+
+    class procedure trtti_attribute_list.ppuwrite(attrlist:trtti_attribute_list;ppufile:tcompilerppufile);
+      var
+        i : longint;
+      begin
+        if assigned(attrlist) and assigned(attrlist.rtti_attributes) then
+          begin
+            ppufile.putlongint(attrlist.rtti_attributes.count);
+            for i:=0 to attrlist.rtti_attributes.count-1 do
+              trtti_attribute(attrlist.rtti_attributes[i]).ppuwrite(ppufile);
+          end
+        else
+          ppufile.putlongint(0);
+      end;
+
 
 {****************************************************************************
                                  TORDDEF

compiler/symsym.pas

@@ -56,6 +56,7 @@ interface
           procedure ppuload_subentries(ppufile:tcompilerppufile);virtual;
           { this is called directly after ppuwrite }
           procedure ppuwrite_subentries(ppufile:tcompilerppufile);virtual;
+          procedure deref; override;
           procedure buildderef; override;
           procedure register_sym; override;
        end;
@@ -572,6 +573,7 @@ implementation
            deprecatedmsg:=ppufile.getpshortstring
          else
            deprecatedmsg:=nil;
+         rtti_attribute_list:=trtti_attribute_list.ppuload(ppufile);
       end;
 
 
@@ -596,18 +598,27 @@ implementation
          if sp_has_deprecated_msg in symoptions then
            ppufile.putstring(deprecatedmsg^);
          ppufile.do_interface_crc:=oldintfcrc;
+         trtti_attribute_list.ppuwrite(rtti_attribute_list,ppufile);
       end;
 
 
     procedure tstoredsym.ppuload_subentries(ppufile: tcompilerppufile);
       begin
-        { by default: do nothing }
+        trtti_attribute_list.ppuload_subentries(rtti_attribute_list,ppufile);
       end;
 
 
     procedure tstoredsym.ppuwrite_subentries(ppufile: tcompilerppufile);
       begin
-        { by default: do nothing }
+        trtti_attribute_list.ppuwrite_subentries(rtti_attribute_list,ppufile);
+      end;
+
+
+    procedure tstoredsym.deref;
+      begin
+        inherited;
+        if assigned(rtti_attribute_list) then
+          rtti_attribute_list.deref;
       end;
 
 
@@ -616,6 +627,8 @@ implementation
         inherited;
         if not registered then
           register_sym;
+        if assigned(rtti_attribute_list) then
+          rtti_attribute_list.buildderef;
       end;
 
 

compiler/utils/ppuutils/ppudump.pp

@@ -1688,6 +1688,79 @@ begin
   writeln(Visibility2Str(i));
 end;
 
+procedure readattrs(def: TPpuDef);
+var
+  i,cnt,paras: longint;
+begin
+  cnt:=ppufile.getlongint;
+  if cnt>0 then
+    begin
+      writeln([space,'   Attributes : ']);
+      space:='    '+space;
+      if assigned(def) then
+        SetLength(def.Attrs,cnt);
+      for i:=0 to cnt-1 do
+        begin
+          writeln([space,'** Custom Attribute ',i,' **']);
+          write  ([space,'      Type symbol : ']);
+          if assigned(def) then
+            begin
+              def.Attrs[i].TypeSym:=TPpuRef.Create;
+              readderef('',def.Attrs[i].TypeSym);
+            end
+          else
+            readderef('');
+          write  ([space,' Type constructor : ']);
+          if assigned(def) then
+            begin
+              def.Attrs[i].TypeConstr:=TPpuRef.Create;
+              readderef('',def.Attrs[i].TypeConstr);
+            end
+          else
+            readderef('');
+          paras:=ppufile.getlongint;
+          writeln([space,'       Parameters : ',paras]);
+          if assigned(def) then
+            def.Attrs[i].ParaCount:=paras;
+        end;
+      delete(space,1,4);
+    end;
+end;
+
+procedure readnodetree; forward;
+
+procedure readattrparas(def: TPpuDef);
+var
+  attr,para: LongInt;
+begin
+  if Length(def.Attrs) > 0 then
+    writeln([space,'   Attr Paras : ']);
+  space:='    '+space;
+  for attr:=0 to High(def.Attrs) do
+    begin
+      writeln([space,'** Custom Attribute ',attr,' Arguments **']);
+      space:='    '+space;
+      for para:=0 to def.Attrs[attr].ParaCount-1 do
+        begin
+          readnodetree;
+        end;
+      delete(space,1,4);
+    end;
+  delete(space,1,4);
+end;
+
+procedure readdefsubentries(def: TPpuDef);
+begin
+  space:='    '+space;
+  readattrparas(def);
+  delete(space,1,4);
+end;
+
+procedure readsymsubentries(def: TPpuDef);
+begin
+  readattrparas(def);
+end;
+
 procedure readcommonsym(const s:string; Def: TPpuDef = nil);
 var
   i: integer;
@@ -1707,6 +1780,7 @@ begin
   readvisibility(Def);
   write  ([space,'   SymOptions : ']);
   readsymoptions(space+'   ',Def);
+  readattrs(Def);
 end;
 
 
@@ -2643,6 +2717,9 @@ begin
       write  ([space,' Orig. GenericDef : ']);
       readderef('');
     end;
+  space:=space+'    ';
+  readattrs(def);
+  delete(space,1,4);
   current_defoptions:=defoptions;
 end;
 
@@ -3652,6 +3729,8 @@ begin
              WriteError('!! Skipping unsupported PPU Entry in Symbols: '+IntToStr(b));
            end;
        end;
+       if assigned(def) then
+         readsymsubentries(def);
        if (def <> nil) and (def.Parent = nil) then
          def.Free;
        if not EndOfEntry then
@@ -4375,6 +4454,8 @@ begin
              WriteError('!! Skipping unsupported PPU Entry in definitions: '+IntToStr(b));
            end;
        end;
+       if assigned(def) then
+         readdefsubentries(def);
        if (def <> nil) and (def.Parent = nil) then
          def.Free;
        if not EndOfEntry then

compiler/utils/ppuutils/ppuout.pp

@@ -97,6 +97,12 @@ type
 
   TPpuDefVisibility = (dvPublic, dvPublished, dvProtected, dvPrivate, dvHidden);
 
+  TPpuAttr = record
+    ParaCount: LongInt;
+    TypeSym: TPpuRef;
+    TypeConstr: TPpuRef;
+  end;
+
   { TPpuDef }
 
   TPpuDef = class
@@ -121,6 +127,7 @@ type
     // Symbol/definition reference
     Ref: TPpuRef;
     Visibility: TPpuDefVisibility;
+    Attrs: array of TPpuAttr;
 
     constructor Create(AParent: TPpuContainerDef); virtual; reintroduce;
     destructor Destroy; override;
@@ -1503,6 +1510,8 @@ begin
 end;
 
 procedure TPpuDef.WriteDef(Output: TPpuOutput);
+var
+  i: SizeInt;
 begin
   with Output do begin
     if FId <> InvalidId then
@@ -1523,6 +1532,17 @@ begin
     end;
     if Visibility <> dvPublic then
       WriteStr('Visibility', DefVisibilityNames[Visibility]);
+    if Length(Attrs) > 0 then begin
+      WriteArrayStart('Attributes');
+      for i:=0 to High(Attrs) do begin
+        WriteObjectStart('');
+        Attrs[i].TypeSym.Write(Output, 'TypeSym');
+        Attrs[i].TypeConstr.Write(Output, 'TypeConstr');
+        WriteInt('ParaCount', Attrs[i].ParaCount, False);
+        WriteObjectEnd('');
+      end;
+      WriteArrayEnd('Attributes');
+    end;
   end;
 end;
 

tests/test/tcustomattr14.pp

@@ -0,0 +1,10 @@
+{ %NORUN }
+{ %RECOMPILE }
+
+program tcustomattr14;
+
+uses
+  ucustomattr14b;
+
+begin
+end.

tests/test/ucustomattr14a.pp

@@ -0,0 +1,23 @@
+unit ucustomattr14a;
+
+{$mode objfpc}{$H+}
+
+interface
+
+type
+  TTestAttribute = class(TCustomAttribute)
+  end;
+
+  TTest2Attribute = class(TCustomAttribute)
+    constructor Create(const aStr: String);
+  end;
+
+implementation
+
+constructor TTest2Attribute.Create(const aStr: String);
+begin
+
+end;
+
+end.
+

tests/test/ucustomattr14b.pp

@@ -0,0 +1,36 @@
+unit ucustomattr14b;
+
+{$mode objfpc}{$H+}
+{$modeswitch prefixedattributes}
+
+interface
+
+uses
+  ucustomattr14a;
+
+type
+  [TTest]
+  TMyClass = class
+
+  end;
+
+  [TTest2('Hello World')]
+  TMyClass2 = class
+
+  end;
+
+  {$M+}
+  TMyClass3 = class
+  private
+    fTest: LongInt;
+  published
+    [TTest2('Foobar')]
+    [TTest]
+    property Test: LongInt read fTest;
+  end;
+  {$M-}
+
+implementation
+
+end.
+