diff --git a/.gitattributes b/.gitattributes index d02b2b0ebb..99ec6e22d3 100644 --- a/.gitattributes +++ b/.gitattributes @@ -11692,6 +11692,7 @@ tests/test/trtti5.pp svneol=native#text/plain tests/test/trtti6.pp svneol=native#text/pascal tests/test/trtti7.pp svneol=native#text/pascal tests/test/trtti8.pp svneol=native#text/pascal +tests/test/trtti9.pp svneol=native#text/pascal tests/test/tsafecall1.pp svneol=native#text/plain tests/test/tsafecall2.pp svneol=native#text/pascal tests/test/tsafecall3.pp svneol=native#text/pascal diff --git a/compiler/ncgrtti.pas b/compiler/ncgrtti.pas index ef9efcf4f5..560c424e1e 100644 --- a/compiler/ncgrtti.pas +++ b/compiler/ncgrtti.pas @@ -693,43 +693,63 @@ implementation { pocall_interrupt } 12 ); - procedure write_para(parasym:tparavarsym); - var - paraspec : byte; - begin - { only store user visible parameters } - if not(vo_is_hidden_para in parasym.varoptions) then - begin - case parasym.varspez of - vs_value : paraspec := 0; - vs_const : paraspec := pfConst; - vs_var : paraspec := pfVar; - vs_out : paraspec := pfOut; - vs_constref: paraspec := pfConstRef; - end; - { Kylix also seems to always add both pfArray and pfReference - in this case - } - if is_open_array(parasym.vardef) then - paraspec:=paraspec or pfArray or pfReference; - { and these for classes and interfaces (maybe because they - are themselves addresses?) - } - if is_class_or_interface(parasym.vardef) then - paraspec:=paraspec or pfAddress; - { set bits run from the highest to the lowest bit on - big endian systems - } - if (target_info.endian = endian_big) then - paraspec:=reverse_byte(paraspec); - { write flags for current parameter } - current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(paraspec)); - { write name of current parameter } - write_string(parasym.realname); - { write name of type of current parameter } - write_rtti_name(parasym.vardef); + procedure write_param_flag(parasym:tparavarsym); + var + paraspec : byte; + begin + case parasym.varspez of + vs_value : paraspec := 0; + vs_const : paraspec := pfConst; + vs_var : paraspec := pfVar; + vs_out : paraspec := pfOut; + vs_constref: paraspec := pfConstRef; end; - end; + { Kylix also seems to always add both pfArray and pfReference + in this case + } + if is_open_array(parasym.vardef) then + paraspec:=paraspec or pfArray or pfReference; + { and these for classes and interfaces (maybe because they + are themselves addresses?) + } + if is_class_or_interface(parasym.vardef) then + paraspec:=paraspec or pfAddress; + { set bits run from the highest to the lowest bit on + big endian systems + } + if (target_info.endian = endian_big) then + paraspec:=reverse_byte(paraspec); + { write flags for current parameter } + current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(paraspec)); + end; + + procedure write_para(parasym:tparavarsym); + begin + { only store user visible parameters } + if not(vo_is_hidden_para in parasym.varoptions) then + begin + { write flags for current parameter } + write_param_flag(parasym); + { write name of current parameter } + write_string(parasym.realname); + { write name of type of current parameter } + write_rtti_name(parasym.vardef); + end; + end; + + procedure write_procedure_param(parasym:tparavarsym); + begin + { only store user visible parameters } + if not(vo_is_hidden_para in parasym.varoptions) then + begin + { write flags for current parameter } + write_param_flag(parasym); + { write param type } + current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_sym(ref_rtti(parasym.vardef,fullrtti))); + { write name of current parameter } + write_string(parasym.realname); + end; + end; var methodkind : byte; @@ -795,7 +815,27 @@ implementation current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_sym(ref_rtti(tparavarsym(def.paras[i]).vardef,fullrtti))); end else - write_header(def,tkProcvar); + begin + write_header(def,tkProcvar); + maybe_write_align; + + { flags } + current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(0)); + maybe_write_align; + { write calling convention } + current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(ProcCallOptionToCallConv[def.proccalloption])); + maybe_write_align; + { write result typeinfo } + if is_void(def.returndef) then + current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_sym(nil)) + else + current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_sym(ref_rtti(def.returndef,fullrtti))); + { write parameter count } + current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(def.maxparacount)); + maybe_write_align; + for i:=0 to def.paras.count-1 do + write_procedure_param(tparavarsym(def.paras[i])); + end; end; diff --git a/rtl/objpas/typinfo.pp b/rtl/objpas/typinfo.pp index 0a3be6bcf1..4a4c9b6c1d 100644 --- a/rtl/objpas/typinfo.pp +++ b/rtl/objpas/typinfo.pp @@ -125,6 +125,7 @@ unit typinfo; Dims: array[0..255] of PTypeInfo; end; + PManagedField = ^TManagedField; TManagedField = {$ifndef FPC_REQUIRES_PROPER_ALIGNMENT} packed @@ -134,6 +135,29 @@ unit typinfo; FldOffset: SizeInt; end; + PProcedureParam = ^TProcedureParam; + TProcedureParam = + {$ifndef FPC_REQUIRES_PROPER_ALIGNMENT} + packed + {$endif FPC_REQUIRES_PROPER_ALIGNMENT} + record + Flags: Byte; + ParamType: PPTypeInfo; + Name: ShortString; + end; + + TProcedureSignature = + {$ifndef FPC_REQUIRES_PROPER_ALIGNMENT} + packed + {$endif FPC_REQUIRES_PROPER_ALIGNMENT} + record + Flags: Byte; + CC: TCallConv; + ResultType: PTypeInfo; + ParamCount: Byte; + {Params: array[1..ParamCount] of TProcedureParam;} + end; + {$PACKRECORDS C} PTypeData = ^TTypeData; TTypeData = @@ -203,6 +227,8 @@ unit typinfo; CC : TCallConv; ParamTypeRefs : array[1..ParamCount] of PTypeInfo;} ); + tkProcVar: + (ProcSig: TProcedureSignature); tkInt64: (MinInt64Value, MaxInt64Value: Int64); tkQWord: @@ -223,9 +249,7 @@ unit typinfo; IIDStr: ShortString; ); tkArray: - ( - ArrayData: TArrayTypeData; - ); + (ArrayData: TArrayTypeData); tkDynArray: ( elSize : PtrUInt; @@ -235,13 +259,9 @@ unit typinfo; DynUnitName: ShortStringBase ); tkClassRef: - ( - InstanceType: PTypeInfo; - ); + (InstanceType: PTypeInfo); tkPointer: - ( - RefType: PTypeInfo; - ); + (RefType: PTypeInfo); end; TPropData = diff --git a/tests/test/trtti9.pp b/tests/test/trtti9.pp new file mode 100644 index 0000000000..b2450b9566 --- /dev/null +++ b/tests/test/trtti9.pp @@ -0,0 +1,38 @@ +program trtti9; + +{$mode delphi} + +uses + typinfo; + +type + PProcedureParam = ^TProcedureParam; + TProc = procedure(var A: Integer; S: String); stdcall; + +function TestParam(Param: PProcedureParam; Flags: Byte; ParamType: Pointer; Name: ShortString): Boolean; +begin + Result := (Param^.Flags = Flags) and (Param^.ParamType = ParamType) and (Param^.Name = Name); +end; + +var + Info: PTypeInfo; + Data: PTypeData; + Param: PProcedureParam; +begin + Info := TypeInfo(TProc); + if Info^.Kind <> tkProcedure then + halt(1); + Data := GetTypeData(Info); + if Data^.ProcSig.CC <> ccStdCall then + halt(2); + if Data^.ProcSig.ResultType <> nil then + halt(3); + if Data^.ProcSig.ParamCount <> 2 then + halt(4); + Param := PProcedureParam(PAnsiChar(@Data^.ProcSig.Flags) + SizeOf(TProcedureSignature)); + if not TestParam(Param, 1, TypeInfo(Integer), 'A') then + halt(5); + Param := PProcedureParam(PAnsiChar(@Param^.Name) + (Length(Param^.Name) + 1) * SizeOf(AnsiChar)); + if not TestParam(Param, 0, TypeInfo(String), 'S') then + halt(6); +end. \ No newline at end of file