mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-10-21 00:04:06 +02:00
compiler: write extended RTTI for tkProcVar (tkProcedure in Delphi)
rtl: add appropriate types for tkProcVar RTTI (based on Delphi help) + test git-svn-id: trunk@24468 -
This commit is contained in:
paul
parent
2d67a3169d
commit
bc973e538d
1
.gitattributes
vendored
1
.gitattributes
vendored
@ -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
|
||||
|
||||
@ -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;
|
||||
|
||||
|
||||
|
||||
@ -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 =
|
||||
|
||||
38
tests/test/trtti9.pp
Normal file
38
tests/test/trtti9.pp
Normal file
@ -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.
|
||||
Loading…
Reference in New Issue
Block a user