diff --git a/.gitattributes b/.gitattributes index f2bfab7acb..a20dbba0b1 100644 --- a/.gitattributes +++ b/.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 diff --git a/compiler/ncgrtti.pas b/compiler/ncgrtti.pas index 6d6cbee570..c852075801 100644 --- a/compiler/ncgrtti.pas +++ b/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; diff --git a/compiler/symconst.pas b/compiler/symconst.pas index abb82695d5..1554247c13 100644 --- a/compiler/symconst.pas +++ b/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$', diff --git a/rtl/objpas/typinfo.pp b/rtl/objpas/typinfo.pp index 612df4a651..f742fd465b 100644 --- a/rtl/objpas/typinfo.pp +++ b/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; diff --git a/tests/test/tcustomattr13.pp b/tests/test/tcustomattr13.pp new file mode 100644 index 0000000000..c7720ff5de --- /dev/null +++ b/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.