* the RTTI of an attribute not only consists of the creation function, but also of the attribute's type, a pointer to the constructor and a data blob containing the constant parameters

+ added test

git-svn-id: trunk@42390 -

.gitattributes

@@ -13209,6 +13209,7 @@ tests/test/tcustomattr1.pp svneol=native#text/pascal
 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/tcustomattr2.pp svneol=native#text/pascal
 tests/test/tcustomattr3.pp svneol=native#text/pascal
 tests/test/tcustomattr4.pp svneol=native#text/pascal

compiler/ncgrtti.pas

@@ -88,6 +88,7 @@ implementation
     uses
        cutils,
        globals,verbose,systems,
+       node,ncal,ncon,
        fmodule, procinfo,
        symtable,
        aasmtai,aasmdata,
@@ -1773,8 +1774,64 @@ implementation
       end;
 
   procedure TRTTIWriter.write_attribute_data(tcb:ttai_typedconstbuilder;attr_list:trtti_attribute_list);
+
+    procedure write_args(tbltcb:ttai_typedconstbuilder;attr:trtti_attribute);
+      var
+        argtcb : ttai_typedconstbuilder;
+        arglab : tasmlabel;
+        argdef : tdef;
+        i : sizeint;
+        arglen : word;
+      begin
+        if length(attr.paras)=0 then
+          begin
+            tbltcb.emit_tai(tai_const.Create_16bit(0),u16inttype);
+            tbltcb.emit_tai(tai_const.Create_nil_dataptr,voidpointertype);
+          end
+        else
+          begin
+            current_asmdata.getglobaldatalabel(arglab);
+
+            argtcb:=ctai_typedconstbuilder.create([tcalo_is_lab,tcalo_make_dead_strippable,tcalo_apply_constalign]);
+
+            argtcb.begin_anonymous_record('',defaultpacking,min(reqalign,SizeOf(PInt)),
+              targetinfos[target_info.system]^.alignment.recordalignmin,
+              targetinfos[target_info.system]^.alignment.maxCrecordalign);
+
+            arglen:=0;
+            for i:=0 to High(attr.paras) do
+              begin
+                case attr.paras[i].nodetype of
+                  niln,
+                  ordconstn,
+                  realconstn,
+                  stringconstn,
+                  pointerconstn,
+                  guidconstn:
+                    inc(arglen,tconstnode(attr.paras[i]).emit_data(argtcb));
+                  setconstn:
+                    inc(arglen,tsetconstnode(attr.paras[i]).emit_data(argtcb));
+                  else
+                    internalerror(2019070803);
+                end;
+              end;
+
+            argdef:=argtcb.end_anonymous_record;
+
+            current_asmdata.asmlists[al_rtti].concatlist(
+              argtcb.get_final_asmlist(arglab,argdef,sec_rodata,arglab.name,const_align(sizeof(pint)))
+            );
+
+            argtcb.free;
+
+            { write argument size and the reference to the argument entry }
+            tbltcb.emit_ord_const(arglen,u16inttype);
+            tbltcb.emit_tai(Tai_const.Create_sym(arglab),voidpointertype);
+          end;
+      end;
+
     var
-      count, i: word;
+      count,i,len: word;
       attr : trtti_attribute;
       tbltcb : ttai_typedconstbuilder;
       tbllab : tasmlabel;
@@ -1797,19 +1854,27 @@ implementation
 
       tbltcb:=ctai_typedconstbuilder.create([tcalo_is_lab,tcalo_make_dead_strippable,tcalo_apply_constalign]);
 
-      tbltcb.begin_anonymous_record('',defaultpacking,min(reqalign,SizeOf(PInt)),
+      tbltcb.begin_anonymous_record(
+        internaltypeprefixName[itp_rtti_attr_list]+tostr(count),
+        defaultpacking,min(reqalign,SizeOf(PInt)),
         targetinfos[target_info.system]^.alignment.recordalignmin,
         targetinfos[target_info.system]^.alignment.maxCrecordalign);
       tbltcb.emit_ord_const(count,u16inttype);
       for i:=0 to count-1 do
         begin
-          tbltcb.begin_anonymous_record('',defaultpacking,min(reqalign,SizeOf(PInt)),
+          tbltcb.begin_anonymous_record(internaltypeprefixName[itp_rtti_attr_entry],defaultpacking,min(reqalign,SizeOf(PInt)),
             targetinfos[target_info.system]^.alignment.recordalignmin,
             targetinfos[target_info.system]^.alignment.maxCrecordalign);
           attr:=trtti_attribute(attr_list.rtti_attributes[i]);
 
+          write_rtti_reference(tbltcb,ttypesym(attr.typesym).typedef,fullrtti);
+
+          tbltcb.emit_procdef_const(tprocdef(tcallnode(attr.constructorcall).procdefinition));
+
           tbltcb.emit_tai(tai_const.Createname(attr.symbolname,AT_DATA_FORCEINDIRECT,0),cpointerdef.getreusable(ttypesym(attr.typesym).typedef));
 
+          write_args(tbltcb,attr);
+
           tbltcb.end_anonymous_record;
         end;
       tbldef:=tbltcb.end_anonymous_record;
@@ -1824,6 +1889,7 @@ implementation
       tcb.emit_tai(Tai_const.Create_sym(tbllab),voidpointertype);
     end;
 
+
     function enumsym_compare_name(item1, item2: pointer): Integer;
       var
         enum1: tenumsym absolute item1;

compiler/symconst.pas

@@ -733,6 +733,8 @@ type
     itp_rtti_common_data,
     itp_rtti_prop,
     itp_rtti_ansistr,
+    itp_rtti_attr_list,
+    itp_rtti_attr_entry,
     itp_rtti_ord_outer,
     itp_rtti_ord_inner,
     itp_rtti_ord_64bit,
@@ -874,6 +876,8 @@ inherited_objectoptions : tobjectoptions = [oo_has_virtual,oo_has_private,oo_has
        '$rtti_common_data$',
        '$rtti_prop$',
        '$rtti_ansistr$',
+       '$rtti_attr_list$',
+       '$rtti_attr_entry$',
        '$rtti_ord_outer$',
        '$rtti_ord_inner$',
        '$rtti_ord_64bit$',

rtl/objpas/typinfo.pp

@@ -254,8 +254,20 @@ unit TypInfo;
 {$endif}
 
       TAttributeProc = function : TCustomAttribute;
-      PAttributeProcList = ^TAttributeProcList;
+
-      TAttributeProcList = array[0..$ffff] of TAttributeProc;
+      TAttributeEntry =
+      {$ifndef FPC_REQUIRES_PROPER_ALIGNMENT}
+      packed
+      {$endif}
+      record
+        AttrType: PPTypeInfo;
+        AttrCtor: CodePointer;
+        AttrProc: TAttributeProc;
+        ArgLen: Word;
+        ArgData: Pointer;
+      end;
+
+      TAttributeEntryList = array[0..$ffff] of TAttributeEntry;
 
       TAttributeTable =
       {$ifndef FPC_REQUIRES_PROPER_ALIGNMENT}
@@ -263,7 +275,7 @@ unit TypInfo;
       {$endif}
       record
         AttributeCount: word;
-        AttributesList: TAttributeProcList;
+        AttributesList: TAttributeEntryList;
       end;
       PAttributeTable = ^TAttributeTable;
 
@@ -1022,7 +1034,7 @@ begin
     result := nil
   else
     begin
-      result := AttributeTable^.AttributesList[AttributeNr]();
+      result := AttributeTable^.AttributesList[AttributeNr].AttrProc();
     end;
 end;
 

tests/test/tcustomattr13.pp

@@ -0,0 +1,182 @@
+program tcustomattr13;
+
+{$mode objfpc}
+{$modeswitch prefixedattributes}
+
+uses
+  TypInfo, Classes, SysUtils;
+
+type
+  TString8 = String[8];
+  TSet = set of (One, Two, Three);
+
+const
+  StrHelloWorld = 'Hello World';
+  StrFoobar = 'Foobar';
+  StrBlubb = 'Blubb';
+
+  ByteVal = $5a;
+  CurrVal = 33.51;
+  CompVal = 1234;
+  SingleVal = 3.14156;
+  SetVal = [One, Three];
+
+type
+  TMyAttr = class(TCustomAttribute)
+    constructor Create(aByte: Byte; aStr: TString8; aFlt: Single);
+    constructor Create(aStr: AnsiString; aSet: TSet; aPtr: Pointer);
+    constructor Create(aComp: Comp; aCurr: Currency; aGuid: TGUID; aStr: UnicodeString);
+  end;
+
+  [TMyAttr(ByteVal, StrHelloWorld, SingleVal)]
+  [TMyAttr(StrFoobar, SetVal, Nil)]
+  [TMyAttr(CompVal, CurrVal, IInterface, StrBlubb)]
+  TMyClass = class
+  end;
+
+constructor TMyAttr.CReate(aByte: Byte; aStr: TString8; aFlt: Single);
+begin
+end;
+
+constructor TMyAttr.Create(aStr: AnsiString; aSet: TSet; aPtr: Pointer);
+begin
+end;
+
+constructor TMyAttr.Create(aComp: Comp; aCurr: Currency; aGuid: TGUID; aStr: UnicodeString);
+begin
+
+end;
+
+procedure DumpData(aData: Pointer; aSize: SizeInt);
+var
+  i: SizeInt;
+  chars: String[16];
+begin
+  chars := '                ';
+  for i := 0 to aSize - 1 do begin
+    if i mod 16 = 0 then begin
+      if i > 0 then begin
+        Writeln('   ', chars);
+        chars := '                ';
+      end;
+      Write(HexStr(PtrUInt(aData) + i, SizeOF(PtrUInt) * 2), '   ');
+    end;
+    Write(HexStr((PByte(aData) + i)^, 2), ' ');
+    if (PByte(aData)[i] >= $20) and (PByte(aData)[i] < $7F) then
+      chars[(i mod 16) + 1] := Chr(PByte(aData)[i])
+    else
+      chars[(i mod 16) + 1] := '.';
+  end;
+  while aSize mod 16 <> 0 do begin
+    Write('   ');
+    Inc(aSize);
+  end;
+  Writeln('   ', chars);
+end;
+
+procedure CheckAttr1(aStrm: TStream);
+var
+  b: Byte;
+  ss: ShortString;
+  s: Single;
+begin
+  if aStrm.Read(b, SizeOf(b)) <> SizeOf(b) then
+    Halt(20);
+  if b <> ByteVal then
+    Halt(21);
+  if aStrm.Read(b, SizeOf(b)) <> SizeOf(b) then
+    Halt(22);
+  if b <> Length(StrHelloWorld) then
+    Halt(23);
+  SetLength(ss, b);
+  if aStrm.Read(ss[1], b) <> b then
+    Halt(24);
+  if ss <> StrHelloWorld then
+    Halt(25);
+  if aStrm.Read(s, SizeOf(Single)) <> SizeOf(Single) then
+    Halt(26);
+  if s <> Single(SingleVal) then
+    Halt(27);
+end;
+
+procedure CheckAttr2(aStrm: TStream);
+var
+  p: Pointer;
+  s: TSet;
+begin
+  if aStrm.Read(p, SizeOf(p)) <> SizeOf(p) then
+    Halt(40);
+  if AnsiString(p) <> StrFoobar then
+    Halt(41);
+  if aStrm.Read(s, SizeOf(s)) <> SizeOf(s) then
+    Halt(42);
+  if s <> SetVal then
+    Halt(43);
+  if aStrm.Read(p, SizeOf(p)) <> SizeOf(p) then
+    Halt(44);
+  if Assigned(p) then
+    Halt(45);
+end;
+
+procedure CheckAttr3(aStrm: TStream);
+var
+  co: Comp;
+  cu: Currency;
+  p: Pointer;
+  g: TGUID;
+begin
+  if aStrm.Read(co, SizeOf(co)) <> SizeOf(co) then
+    Halt(60);
+  if co <> CompVal then
+    Halt(61);
+  if aStrm.Read(cu, SizeOf(cu)) <> SizeOf(cu) then
+    Halt(62);
+  if cu <> CurrVal then
+    Halt(63);
+  if aStrm.Read(g, SizeOf(g)) <> SizeOf(g) then
+    Halt(64);
+  if not IsEqualGUID(g,TGuid(IInterface)) then
+    Halt(65);
+  if aStrm.Read(p, SizeOf(p)) <> SizeOf(p) then
+    Halt(66);
+  if UnicodeString(p) <> StrBlubb then
+    Halt(67);
+end;
+
+type
+  TCheckProc = procedure(aStrm: TStream);
+
+const
+  CheckProcs: array[0..2] of TCheckProc = (
+    @CheckAttr1,
+    @CheckAttr2,
+    @CheckAttr3
+  );
+
+var
+  at: PAttributeTable;
+  ae: TAttributeEntry;
+  i: SizeInt;
+  strm: TMemoryStream;
+begin
+  at := GetAttributeTable(TypeInfo(TMyClass));
+  if at^.AttributeCount = 0 then
+    Halt(1);
+  if at^.AttributeCount > Length(CheckProcs) then
+    Halt(2);
+
+  for i := 0 to at^.AttributeCount - 1 do begin
+    ae := at^.AttributesList[i];
+    if ae.AttrType^ <> TMyAttr.ClassInfo then
+      Halt(3);
+    if not Assigned(ae.AttrCtor) then
+      Halt(4);
+    if not Assigned(ae.AttrProc) then
+      Halt(5);
+    strm:=TMemoryStream.Create;
+    strm.SetSize(ae.ArgLen);
+    Move(ae.ArgData^, strm.Memory^, ae.ArgLen);
+    CheckProcs[i](strm);
+  end;
+  Writeln('ok');
+end.