From 59a1199110f4b4f9d937817994c2f369365ffbbe Mon Sep 17 00:00:00 2001 From: Frederic Kehrein Date: Thu, 31 Oct 2024 15:21:17 +0100 Subject: [PATCH] Adding support for indexed properties in extended RTTI --- compiler/ncgrtti.pas | 94 +++++++++++++++++++++++++++++------------ rtl/objpas/typinfo.pp | 12 ++++++ tests/test/texrtti19.pp | 43 +++++++++++++++++++ tests/test/texrtti20.pp | 35 +++++++++++++++ 4 files changed, 156 insertions(+), 28 deletions(-) create mode 100644 tests/test/texrtti19.pp create mode 100644 tests/test/texrtti20.pp diff --git a/compiler/ncgrtti.pas b/compiler/ncgrtti.pas index c83be6987f..95921c9d7c 100644 --- a/compiler/ncgrtti.pas +++ b/compiler/ncgrtti.pas @@ -69,6 +69,7 @@ interface procedure write_callconv(tcb:ttai_typedconstbuilder;def:tabstractprocdef); procedure write_paralocs(tcb:ttai_typedconstbuilder;para:pcgpara); procedure write_param_flag(tcb:ttai_typedconstbuilder;parasym:tparavarsym); + procedure write_param(tcb:ttai_typedconstbuilder;para:tparavarsym); procedure write_mop_offset_table(tcb:ttai_typedconstbuilder;def:tabstractrecorddef;mop:tmanagementoperator); procedure maybe_add_comment(tcb:ttai_typedconstbuilder;const comment : string); inline; public @@ -333,32 +334,7 @@ implementation end; for k:=0 to def.paras.count-1 do - begin - para:=tparavarsym(def.paras[k]); - - maybe_add_comment(tcb,'RTTI: begin param '+para.prettyname); - tcb.begin_anonymous_record('',defaultpacking,min(reqalign,SizeOf(PInt)), - targetinfos[target_info.system]^.alignment.recordalignmin); - - maybe_add_comment(tcb,#9'type'); - if is_open_array(para.vardef) or is_array_of_const(para.vardef) then - write_rtti_reference(tcb,tarraydef(para.vardef).elementdef,fullrtti) - else if para.vardef=cformaltype then - write_rtti_reference(tcb,nil,fullrtti) - else - write_rtti_reference(tcb,para.vardef,fullrtti); - maybe_add_comment(tcb,#9'flags'); - write_param_flag(tcb,para); - - maybe_add_comment(tcb,#9'name'); - tcb.emit_pooled_shortstring_const_ref(para.realname); - - maybe_add_comment(tcb,#9'locs'); - write_paralocs(tcb,@para.paraloc[callerside]); - - tcb.end_anonymous_record; - maybe_add_comment(tcb,'RTTI: end param '+para.prettyname); - end; + write_param(tcb,tparavarsym(def.paras[k])); if not is_void(def.returndef) then begin @@ -562,6 +538,33 @@ implementation tcb.emit_ord_const(paraspec,u16inttype); end; + procedure TRTTIWriter.write_param(tcb: ttai_typedconstbuilder; + para: tparavarsym); + begin + maybe_add_comment(tcb,'RTTI: begin param '+para.prettyname); + tcb.begin_anonymous_record('',defaultpacking,min(reqalign,SizeOf(PInt)), + targetinfos[target_info.system]^.alignment.recordalignmin); + + maybe_add_comment(tcb,#9'type'); + if is_open_array(para.vardef) or is_array_of_const(para.vardef) then + write_rtti_reference(tcb,tarraydef(para.vardef).elementdef,fullrtti) + else if para.vardef=cformaltype then + write_rtti_reference(tcb,nil,fullrtti) + else + write_rtti_reference(tcb,para.vardef,fullrtti); + maybe_add_comment(tcb,#9'flags'); + write_param_flag(tcb,para); + + maybe_add_comment(tcb,#9'name'); + tcb.emit_pooled_shortstring_const_ref(para.realname); + + maybe_add_comment(tcb,#9'locs'); + write_paralocs(tcb,@para.paraloc[callerside]); + + tcb.end_anonymous_record; + maybe_add_comment(tcb,'RTTI: end param '+para.prettyname); + end; + function compare_mop_offset_entry(item1,item2:pointer):longint; var @@ -1062,12 +1065,40 @@ implementation sym:=tsym(st.SymList[i]); if (tsym(sym).typ=propertysym) and (sym.visibility in visibilities) and - (tpropertysym(sym).parast=Nil) and + (extended_rtti or (tpropertysym(sym).parast=Nil)) and not (sp_static in sym.symoptions) then inc(result); end; end; + procedure write_prop_params(tcb:ttai_typedconstbuilder;paramst:tsymtable); + var + paramtcb : ttai_typedconstbuilder; + paramlbl : tasmlabel; + paramdef : tdef; + i : longint; + begin + tcb.start_internal_data_builder(current_asmdata.AsmLists[al_rtti],sec_rodata,'',paramtcb,paramlbl); + + paramtcb.begin_anonymous_record('',defaultpacking,min(reqalign,SizeOf(PInt)), + targetinfos[target_info.system]^.alignment.recordalignmin); + + { paramcount } + paramtcb.emit_ord_const(paramst.symlist.count,u32inttype); + for i:=0 to paramst.symlist.count-1 do + begin + if tsym(paramst.symlist[i]).typ<>paravarsym then + Internalerror(2024103101); + write_param(paramtcb,tparavarsym(paramst.symlist[i])); + end; + + + paramdef:=paramtcb.end_anonymous_record; + tcb.finish_internal_data_builder(paramtcb,paramlbl,paramdef,sizeof(pint)); + + tcb.emit_tai(tai_const.Create_sym(paramlbl),voidpointertype); + end; + function write_propinfo_data(tcb: ttai_typedconstbuilder; sym: tpropertysym): tdef; begin { we can only easily reuse defs if the property is not stored, @@ -1127,6 +1158,13 @@ implementation if addcomments then tcb.emit_comment(#9'proc types'); tcb.emit_ord_const(proctypesinfo,u8inttype); + { index parameters } + if addcomments then + tcb.emit_comment(#9'indexed params'); + if extended_rtti and assigned(tpropertysym(sym).parast) then + write_prop_params(tcb,sym.parast) + else + tcb.emit_tai(tai_const.create_nil_dataptr,voidpointertype); { write reference to attribute table } if addcomments then tcb.emit_comment(#9'attributes'); @@ -1153,7 +1191,7 @@ implementation sym:=tsym(st.SymList[i]); if (sym.typ=propertysym) and (sym.visibility in visibilities) and - (tpropertysym(sym).parast=Nil) and + (extended_rtti or (tpropertysym(sym).parast=Nil)) and not (sp_static in sym.symoptions) then begin if extended_rtti then diff --git a/rtl/objpas/typinfo.pp b/rtl/objpas/typinfo.pp index 75105921b5..e93f6093a7 100644 --- a/rtl/objpas/typinfo.pp +++ b/rtl/objpas/typinfo.pp @@ -1092,6 +1092,16 @@ unit TypInfo; PPropListEx = ^TPropListEx; TPropListEx = array[0..{$ifdef cpu16}(32768 div sizeof(PPropInfoEx))-2{$else}65535{$endif}] of PPropInfoEx; + TPropParams = + {$ifndef FPC_REQUIRES_PROPER_ALIGNMENT} + packed + {$ENDIF FPC_REQUIRES_PROPER_ALIGNMENT} + record + Count: LongInt; + Params: array[0..0] of TVmtMethodParam; + end; + PPropParams = ^TPropParams; + {$PACKRECORDS 1} TPropInfo = packed record private @@ -1114,6 +1124,8 @@ unit TypInfo; // 6 : true, constant index property PropProcs : Byte; + PropParams : PPropParams; + {$ifdef PROVIDE_ATTR_TABLE} AttributeTable : PAttributeTable; {$endif} diff --git a/tests/test/texrtti19.pp b/tests/test/texrtti19.pp new file mode 100644 index 0000000000..5609ab6e6b --- /dev/null +++ b/tests/test/texrtti19.pp @@ -0,0 +1,43 @@ +{$Mode ObjFpc} + +uses TypInfo; + +type + {$RTTI EXPLICIT + FIELDS([vcPublic]) + PROPERTIES([vcPublic,vcPublished]) + METHODS([vcPublic,vcPublished]) + } + TTestClass = class + public + fa:integer; + function MyMethod(const arg1: Integer): Integer; + property TestIProp[const i: Longint]: Integer read MyMethod; + property TestProp: Integer read fa; + end; + +function TTestClass.MyMethod(const arg1: Integer): Integer; +begin + Result := arg1; +end; + +var + pcd: PClassData; +begin + pcd:=PClassData(GetTypeData(TypeInfo(TTestClass))); + if pcd^.ExRTTITable^.PropCount <> 2 then + Halt(1); + if not assigned(pcd^.ExRTTITable^.Prop[0]^.Info^.PropParams) then + Halt(2); + if pcd^.ExRTTITable^.Prop[0]^.Info^.PropParams^.Count<>1 then + Halt(3); + if pcd^.ExRTTITable^.Prop[0]^.Info^.PropParams^.Params[0].Name<>'i' then + Halt(4); + if not (pfconst in pcd^.ExRTTITable^.Prop[0]^.Info^.PropParams^.Params[0].flags) then + Halt(5); + if pcd^.ExRTTITable^.Prop[0]^.Info^.PropParams^.Params[0].ParamType^^.Name<>'LongInt' then + Halt(6); + if assigned(pcd^.ExRTTITable^.Prop[1]^.Info^.PropParams) then + Halt(7); + WriteLn('Ok'); +end. diff --git a/tests/test/texrtti20.pp b/tests/test/texrtti20.pp new file mode 100644 index 0000000000..825f5fc4d1 --- /dev/null +++ b/tests/test/texrtti20.pp @@ -0,0 +1,35 @@ +{$Mode ObjFpc} + +uses TypInfo; + +type + {$RTTI EXPLICIT + FIELDS([vcPublic]) + PROPERTIES([vcPublic,vcPublished]) + METHODS([vcPublic,vcPublished]) + } + TTestClass = class + public + fa:integer; + function MyMethod(const arg1: Integer): Integer; + property TestIProp[const i: Longint]: Integer read MyMethod; + published + property TestProp: Integer read fa; + end; + +function TTestClass.MyMethod(const arg1: Integer): Integer; +begin + Result := arg1; +end; + +var + pcd: PClassData; +begin + pcd:=PClassData(GetTypeData(TypeInfo(TTestClass))); + WriteLn(pcd^.PropertyTable^.PropCount); + if pcd^.PropertyTable^.PropCount <> 1 then + Halt(1); + if assigned(pcd^.PropertyTable^.Prop[0]^.PropParams) then + Halt(2); + WriteLn('Ok'); +end.