paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-07 12:07:58 +02:00
Code Issues Packages Projects Releases Wiki Activity

* parameter type needs to be Nil for formal parameters (Delphi compatible)

Browse Source 
* adjusted test trtti15
+ added test trtti19

git-svn-id: trunk@41770 -
This commit is contained in:
svenbarth 2019-03-22 22:29:20 +00:00
parent 04ee584a7d
commit f7817d25ff
4 changed files with 100 additions and 4 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.gitattributes vendored
View File

@ -13964,6 +13964,7 @@ tests/test/trtti16.pp svneol=native#text/pascal
tests/test/trtti17.pp svneol=native#text/pascal
tests/test/trtti18a.pp svneol=native#text/pascal
tests/test/trtti18b.pp svneol=native#text/pascal
tests/test/trtti19.pp svneol=native#text/pascal
tests/test/trtti2.pp svneol=native#text/plain
tests/test/trtti3.pp svneol=native#text/plain
tests/test/trtti4.pp svneol=native#text/plain

6
compiler/ncgrtti.pas
View File

@ -256,6 +256,8 @@ implementation
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);
write_param_flag(tcb,para);
@ -1395,6 +1397,8 @@ implementation
{ write param type }
if is_open_array(parasym.vardef) or is_array_of_const(parasym.vardef) then
write_rtti_reference(tcb,tarraydef(parasym.vardef).elementdef,fullrtti)
else if parasym.vardef=cformaltype then
write_rtti_reference(tcb,nil,fullrtti)
else
write_rtti_reference(tcb,parasym.vardef,fullrtti);
{ write name of current parameter }
@ -1442,6 +1446,8 @@ implementation
begin
if is_open_array(tparavarsym(def.paras[i]).vardef) or is_array_of_const(tparavarsym(def.paras[i]).vardef) then
write_rtti_reference(tcb,tarraydef(tparavarsym(def.paras[i]).vardef).elementdef,fullrtti)
else if tparavarsym(def.paras[i]).vardef=cformaltype then
write_rtti_reference(tcb,nil,fullrtti)
else
write_rtti_reference(tcb,tparavarsym(def.paras[i]).vardef,fullrtti);
end;

20
tests/test/trtti15.pp
View File

@ -24,6 +24,7 @@ type
function Test7(arg1: LongInt; arg2: String): String; pascal;
{$endif}
function Test8(arg1: LongInt; arg2: String): String; cdecl;
procedure Test9(var arg1; out arg2; constref arg3);
property T: LongInt read Test2;
property T2: LongInt read Test2;
end;
@ -52,10 +53,15 @@ begin
ErrorHalt('Expected parameter name %s, but got %s', [aName, aParam^.Name]);
if aParam^.Flags <> aFlags then
ErrorHalt('Expected parameter flags %s, but got %s', [HexStr(Word(aFlags), 4), HexStr(Word(aParam^.Flags), 4)]);
if not Assigned(aParam^.ParamType) then
ErrorHalt('Expected parameter type %s, but got Nil', [aTypeInfo^.Name]);
if aParam^.ParamType^ <> aTypeInfo then
ErrorHalt('Expected parameter type %s, but got %s', [aTypeInfo^.Name, aParam^.ParamType^^.Name]);
if Assigned(aTypeInfo) then begin
if not Assigned(aParam^.ParamType) then
ErrorHalt('Expected parameter type %s, but got Nil', [aTypeInfo^.Name]);
if aParam^.ParamType^ <> aTypeInfo then
ErrorHalt('Expected parameter type %s, but got %s', [aTypeInfo^.Name, aParam^.ParamType^^.Name]);
end else begin
if Assigned(aParam^.ParamType) then
ErrorHalt('Expected Nil parameter type, but got %s', [aParam^.ParamType^^.Name])
end;
end;
type
@ -221,6 +227,12 @@ begin
MakeParam('$self', [pfHidden, pfSelf, pfAddress], TypeInfo(ITest)),
MakeParam('arg1', [], TypeInfo(LongInt)),
MakeParam('arg2', [], TypeInfo(String))
]),
MakeMethod('Test9', DefaultCallingConvention, mkProcedure, Nil, [
MakeParam('$self', [pfHidden, pfSelf, pfAddress], TypeInfo(ITest)),
MakeParam('arg1', [pfVar], Nil),
MakeParam('arg2', [pfOut], Nil),
MakeParam('arg3', [pfConstRef], Nil)
])
]);
end.

77
tests/test/trtti19.pp Normal file
View File

@ -0,0 +1,77 @@
program trtti19;
{$mode objfpc}
uses
TypInfo;
type
TTestProc = procedure(var arg1; out arg2; constref arg3);
TTestMethod = procedure(var arg1; out arg2; constref arg3) of object;
PParamFlags = ^TParamFlags;
PPPTypeInfo = ^PPTypeInfo;
var
ti: PTypeInfo;
td: PTypeData;
procparam: PProcedureParam;
pb: PByte;
i: SizeInt;
begin
ti := PTypeInfo(TypeInfo(TTestProc));
td := GetTypeData(ti);
if td^.ProcSig.ParamCount <> 3 then
Halt(1);
procparam := td^.ProcSig.GetParam(0);
if Assigned(procparam^.ParamType) then
Halt(2);
if procparam^.ParamFlags * [pfVar] <> [pfVar] then
Halt(3);
procparam := td^.ProcSig.GetParam(1);
if Assigned(procparam^.ParamType) then
Halt(4);
if procparam^.ParamFlags * [pfOut] <> [pfOut] then
Halt(5);
procparam := td^.ProcSig.GetParam(2);
if Assigned(procparam^.ParamType) then
Halt(6);
if procparam^.ParamFlags * [pfConstRef] <> [pfConstRef] then
Halt(7);
ti := PTypeInfo(TypeInfo(TTestMethod));
td := GetTypeData(ti);
if td^.ParamCount <> 4 then
Halt(8);
pb := @td^.ParamList[0];
if PParamFlags(pb)^ * [pfHidden, pfSelf] <> [pfHidden, pfSelf] then
Halt(9);
pb := pb + SizeOf(TParamFlags);
pb := pb + SizeOf(Byte) + pb^;
pb := pb + SizeOf(Byte) + pb^;
if PParamFlags(pb)^ * [pfVar] <> [pfVar] then
Halt(10);
pb := pb + SizeOf(TParamFlags);
pb := pb + SizeOf(Byte) + pb^;
pb := pb + SizeOf(Byte) + pb^;
if PParamFlags(pb)^ * [pfOut] <> [pfOut] then
Halt(11);
pb := pb + SizeOf(TParamFlags);
pb := pb + SizeOf(Byte) + pb^;
pb := pb + SizeOf(Byte) + pb^;
if PParamFlags(pb)^ * [pfConstRef] <> [pfConstRef] then
Halt(12);
pb := pb + SizeOf(TParamFlags);
pb := pb + SizeOf(Byte) + pb^;
pb := pb + SizeOf(Byte) + pb^;
pb := pb + SizeOf(TCallConv);
for i := 1 to td^.ParamCount - 1 do begin
if PPPTypeInfo(pb)[i] <> Nil then begin
Writeln(PPPTypeInfo(pb)[i]^^.Name);
Halt(12 + i);
end;
end;
Writeln('ok');
end.