[fpc-devel] RTTI interface & variant late binding issue (mORMot)
Steve Hildebrandt
Steve.Kassel at web.de
Fri Feb 20 19:21:50 CET 2015
Here ist the current state of affairs for i386 only right now.
The Patches are currently based on
http://svn.freepascal.org/svn/fpc/trunk@29760
mfg Steve
-------------- next part --------------
>From 10bc4ebe4f8fbec1a733d5d24c01da718f08f734 Mon Sep 17 00:00:00 2001
From: Steve Hildebrandt <Steve.Kassel at web.de>
Date: Fri, 20 Feb 2015 17:00:33 +0100
Subject: [PATCH 1/3] Added Base Structure for delphi compatible interface RTTI
---
compiler/ncgrtti.pas | 197 +++++++++++++++++++++++++++++++++++---------------
rtl/objpas/typinfo.pp | 54 ++++++++++++++
2 files changed, 194 insertions(+), 57 deletions(-)
diff --git a/compiler/ncgrtti.pas b/compiler/ncgrtti.pas
index 9d8e618..ff2cfa7 100644
--- a/compiler/ncgrtti.pas
+++ b/compiler/ncgrtti.pas
@@ -28,7 +28,7 @@ interface
uses
cclasses,constexp,
aasmbase,
- symbase,symconst,symtype,symdef;
+ symbase,symconst,symtype,symdef,symsym;
type
@@ -43,6 +43,8 @@ interface
procedure published_write_rtti(st:tsymtable;rt:trttitype);
function published_properties_count(st:tsymtable):longint;
procedure published_properties_write_rtti_data(propnamelist:TFPHashObjectList;st:tsymtable);
+ procedure write_param_flag(parasym:tparavarsym);
+ procedure methods_write_rtti(st:tsymtable);
procedure collect_propnamelist(propnamelist:TFPHashObjectList;objdef:tobjectdef);
function ref_rtti(def:tdef;rt:trttitype):tasmsymbol;
procedure write_rtti_name(def:tdef);
@@ -69,7 +71,6 @@ implementation
cutils,
globals,globtype,verbose,systems,
fmodule, procinfo,
- symsym,
aasmtai,aasmdata,
defutil,
wpobase
@@ -83,6 +84,23 @@ implementation
symconst.ds_none,symconst.ds_none,
symconst.ds_none,symconst.ds_none);
+ ProcCallOptionToCallConv: array[tproccalloption] of byte = (
+ { pocall_none } 0,
+ { pocall_cdecl } 1,
+ { pocall_cppdecl } 5,
+ { pocall_far16 } 6,
+ { pocall_oldfpccall } 7,
+ { pocall_internproc } 8,
+ { pocall_syscall } 9,
+ { pocall_pascal } 2,
+ { pocall_register } 0,
+ { pocall_safecall } 4,
+ { pocall_stdcall } 3,
+ { pocall_softfloat } 10,
+ { pocall_mwpascal } 11,
+ { pocall_interrupt } 12
+ );
+
type
TPropNameListItem = class(TFPHashObject)
propindex : longint;
@@ -414,6 +432,96 @@ implementation
end;
end;
+ procedure TRTTIWriter.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;
+ else
+ internalerror(2013112904);
+ 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 TRTTIWriter.methods_write_rtti(st: tsymtable);
+ var
+ count: Word;
+ i,j,k: LongInt;
+
+ sym : tprocsym;
+ def : tabstractprocdef;
+ para : tparavarsym;
+
+ reg: Byte;
+ off: LongInt;
+ begin
+ count:=0;
+ for i:=0 to st.SymList.Count-1 do
+ if (tsym(st.SymList[i]).typ=procsym) then
+ inc(count);
+
+ current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_16bit(count));
+ current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_16bit(count));
+
+ for i:=0 to st.SymList.Count-1 do
+ if (tsym(st.SymList[i]).typ=procsym) then
+ begin
+ sym:=tprocsym(st.SymList[i]);
+ for j:=0 to sym.ProcdefList.count-1 do
+ begin
+ def:=tabstractprocdef(sym.ProcdefList[j]);
+ def.init_paraloc_info(callerside);
+
+ write_string(sym.prettyname);
+ current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(3));
+ current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(ProcCallOptionToCallConv[def.proccalloption]));
+ write_rtti_reference(def.returndef,fullrtti);
+ current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_16bit(def.callerargareasize));
+ current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(def.maxparacount + 1));
+
+ for k:=0 to def.paras.count-1 do
+ begin
+ para:=tparavarsym(def.paras[k]);
+
+ { write flags for current parameter }
+ write_param_flag(para);
+ maybe_write_align;
+ { write param type }
+ write_rtti_reference(para.vardef,fullrtti);
+
+ reg:=0;
+ off:=0;
+ current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(reg));
+ current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_32bit(off));
+
+ { write name of current parameter }
+ write_string(para.realname);
+ end;
+ end;
+ end;
+ end;
+
procedure TRTTIWriter.write_rtti_data(def:tdef;rt:trttitype);
@@ -686,55 +794,6 @@ implementation
procedure procvardef_rtti(def:tprocvardef);
- const
- ProcCallOptionToCallConv: array[tproccalloption] of byte = (
- { pocall_none } 0,
- { pocall_cdecl } 1,
- { pocall_cppdecl } 5,
- { pocall_far16 } 6,
- { pocall_oldfpccall } 7,
- { pocall_internproc } 8,
- { pocall_syscall } 9,
- { pocall_pascal } 2,
- { pocall_register } 0,
- { pocall_safecall } 4,
- { pocall_stdcall } 3,
- { pocall_softfloat } 10,
- { pocall_mwpascal } 11,
- { pocall_interrupt } 12
- );
-
- 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;
- else
- internalerror(2013112904);
- 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
@@ -944,15 +1003,24 @@ implementation
maybe_write_align;
{ write iidstr }
- if assigned(def.iidstr) then
- write_string(def.iidstr^)
- else
- current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(0));
- maybe_write_align;
+ if def.objecttype = odt_interfacecorba then
+ begin
+ if assigned(def.iidstr) then
+ write_string(def.iidstr^)
+ else
+ current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(0));
+
+ maybe_write_align;
+ end;
{ write published properties for this object }
+ current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_16bit(published_properties_count(def.symtable)));
+ maybe_write_align;
published_properties_write_rtti_data(propnamelist,def.symtable);
+ { write methods for this object }
+ methods_write_rtti(def.symtable);
+
propnamelist.free;
end;
@@ -1283,6 +1351,8 @@ implementation
end;
procedure TRTTIWriter.write_child_rtti_data(def:tdef;rt:trttitype);
+ var
+ i,j: SizeInt;
begin
case def.typ of
enumdef :
@@ -1304,7 +1374,20 @@ implementation
if (rt=initrtti) or (tobjectdef(def).objecttype=odt_object) then
fields_write_rtti(tobjectdef(def).symtable,rt)
else
- published_write_rtti(tobjectdef(def).symtable,rt);
+ begin
+ published_write_rtti(tobjectdef(def).symtable,rt);
+
+ if is_any_interface_kind(def) then
+ with tobjectdef(def).symtable do
+ for i := 0 to SymList.Count-1 do
+ if (tsym(SymList[i]).typ=procsym) then
+ with tprocsym(tobjectdef(def).symtable.SymList[i]) do
+ for j := 0 to ProcdefList.Count - 1 do
+ begin
+ write_rtti(tabstractprocdef(ProcdefList[j]).returndef,rt);
+ params_write_rtti(tabstractprocdef(ProcdefList[j]),rt);
+ end;
+ end;
end;
classrefdef,
pointerdef:
diff --git a/rtl/objpas/typinfo.pp b/rtl/objpas/typinfo.pp
index 3b44545..e5ae2c2 100644
--- a/rtl/objpas/typinfo.pp
+++ b/rtl/objpas/typinfo.pp
@@ -63,6 +63,7 @@ unit typinfo;
// don't rely on integer values of TCallConv since it includes all conventions
// which both delphi and fpc support. In the future delphi can support more and
// fpc own conventions will be shifted/reordered accordinly
+ PCallConv = ^TCallConv;
TCallConv = (ccReg, ccCdecl, ccPascal, ccStdCall, ccSafeCall,
ccCppdecl, ccFar16, ccOldFPCCall, ccInternProc,
ccSysCall, ccSoftFloat, ccMWPascal);
@@ -161,6 +162,49 @@ unit typinfo;
function GetParam(ParamIndex: Integer): PProcedureParam;
end;
+ PVmtMethodParam = ^TVmtMethodParam;
+ TVmtMethodParam =
+ {$ifndef FPC_REQUIRES_PROPER_ALIGNMENT}
+ packed
+ {$endif FPC_REQUIRES_PROPER_ALIGNMENT}
+ record
+ Flags: TParamFlags;
+ ParamType: PTypeInfo;
+ ParReg: Byte;
+ ParOff: LongInt;
+ Name: ShortString;
+ {Attribute data TODO}
+ end;
+
+ PIntfMethodEntry = ^TIntfMethodEntry;
+ TIntfMethodEntry =
+ {$ifndef FPC_REQUIRES_PROPER_ALIGNMENT}
+ packed
+ {$endif FPC_REQUIRES_PROPER_ALIGNMENT}
+ record
+ Name: ShortString;
+ {
+ Version: Byte;
+ CC: TCallConv;
+ ResultType: PTypeInfo;
+ StackSize: Word;
+ ParamCount: Byte;
+ Params: array[0..ParamCount - 1] of TVmtMethodParam;
+ }
+ {Attribute data TODO}
+ end;
+
+ PIntfMethodTable = ^TIntfMethodTable;
+ TIntfMethodTable =
+ {$ifndef FPC_REQUIRES_PROPER_ALIGNMENT}
+ packed
+ {$endif FPC_REQUIRES_PROPER_ALIGNMENT}
+ record
+ Count: Word;
+ RTTICount: Word;//$FFFF if there is no further info, or the value of Count
+ {Entry: array[0..Count - 1] of TIntfMethodEntry}
+ end;
+
PTypeData = ^TTypeData;
TTypeData =
{$ifndef FPC_REQUIRES_PROPER_ALIGNMENT}
@@ -241,6 +285,11 @@ unit typinfo;
IntfFlags : TIntfFlagsBase;
GUID: TGUID;
IntfUnit: ShortString;
+ {
+ IntfPropCount: SmallInt;
+ IntfProps: array[0..IntfPropCount-1] of TPropInfo;
+ IntfMethTable : TIntfMethodTable;
+ }
);
tkInterfaceRaw:
(
@@ -249,6 +298,11 @@ unit typinfo;
IID: TGUID;
RawIntfUnit: ShortString;
IIDStr: ShortString;
+ {
+ RawIntfPropCount: SmallInt;
+ RawIntfProps: array[0..IntfPropCount-1] of TPropInfo;
+ IntfMethTable : TIntfMethodTable;
+ }
);
tkArray:
(ArrayData: TArrayTypeData);
--
1.9.5.msysgit.0
-------------- next part --------------
>From f914d2a258a2d6dad5c25e37338c1d5703839231 Mon Sep 17 00:00:00 2001
From: Steve Hildebrandt <Steve.Kassel at web.de>
Date: Fri, 20 Feb 2015 19:12:34 +0100
Subject: [PATCH 2/3] Added base for Reg/Off calculation to paramgr
---
compiler/ncgrtti.pas | 11 ++++++++---
compiler/paramgr.pas | 8 ++++++++
2 files changed, 16 insertions(+), 3 deletions(-)
diff --git a/compiler/ncgrtti.pas b/compiler/ncgrtti.pas
index ff2cfa7..1f7b7e9 100644
--- a/compiler/ncgrtti.pas
+++ b/compiler/ncgrtti.pas
@@ -73,7 +73,8 @@ implementation
fmodule, procinfo,
aasmtai,aasmdata,
defutil,
- wpobase
+ wpobase,
+ paramgr
;
@@ -504,14 +505,18 @@ implementation
begin
para:=tparavarsym(def.paras[k]);
+ if (vo_is_hidden_para in para.varoptions) and not
+ (vo_is_self in para.varoptions) then
+ continue;
+
{ write flags for current parameter }
write_param_flag(para);
maybe_write_align;
{ write param type }
write_rtti_reference(para.vardef,fullrtti);
- reg:=0;
- off:=0;
+ paramanager.get_para_regoff(def.proccalloption, para.paraloc[callerside].location,reg,off);
+
current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_8bit(reg));
current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_32bit(off));
diff --git a/compiler/paramgr.pas b/compiler/paramgr.pas
index bb63456..44f767c 100644
--- a/compiler/paramgr.pas
+++ b/compiler/paramgr.pas
@@ -81,6 +81,8 @@ unit paramgr;
function get_volatile_registers_flags(calloption : tproccalloption):tcpuregisterset;virtual;
function get_volatile_registers_mm(calloption : tproccalloption):tcpuregisterset;virtual;
+ procedure get_para_regoff(proccalloption: tproccalloption; paraloc: pcgparalocation; out reg: Byte; out off: LongInt);virtual;
+
procedure getintparaloc(pd: tabstractprocdef; nr : longint; var cgpara: tcgpara);virtual;
{# allocate an individual pcgparalocation that's part of a tcgpara
@@ -278,6 +280,12 @@ implementation
result:=[];
end;
+ procedure tparamanager.get_para_regoff(proccalloption: tproccalloption; paraloc: pcgparalocation; out reg: Byte; out off: LongInt);
+ begin
+ reg:=0;
+ off:=0;
+ end;
+
{$if first_mm_imreg = 0}
{$WARN 4044 OFF} { Comparison might be always false ... }
{$endif}
--
1.9.5.msysgit.0
-------------- next part --------------
>From 7af4e169b0eac7823a0696bf7639be5dfcf4dfef Mon Sep 17 00:00:00 2001
From: Steve Hildebrandt <Steve.Kassel at web.de>
Date: Fri, 20 Feb 2015 19:12:47 +0100
Subject: [PATCH 3/3] Updated paramgr implementation for i386
---
compiler/i386/cpupara.pas | 29 +++++++++++++++++++++++++++--
1 file changed, 27 insertions(+), 2 deletions(-)
diff --git a/compiler/i386/cpupara.pas b/compiler/i386/cpupara.pas
index d310fb5..73cb472 100644
--- a/compiler/i386/cpupara.pas
+++ b/compiler/i386/cpupara.pas
@@ -32,6 +32,9 @@ unit cpupara;
parabase,paramgr;
type
+
+ { ti386paramanager }
+
ti386paramanager = class(tparamanager)
function param_use_paraloc(const cgpara:tcgpara):boolean;override;
function ret_in_param(def:tdef;pd:tabstractprocdef):boolean;override;
@@ -40,6 +43,7 @@ unit cpupara;
function get_volatile_registers_int(calloption : tproccalloption):tcpuregisterset;override;
function get_volatile_registers_fpu(calloption : tproccalloption):tcpuregisterset;override;
function get_volatile_registers_mm(calloption : tproccalloption):tcpuregisterset;override;
+ procedure get_para_regoff(proccalloption: tproccalloption; paraloc: pcgparalocation; out reg: Byte; out off: LongInt);override;
function create_paraloc_info(p : tabstractprocdef; side: tcallercallee):longint;override;
function create_varargs_paraloc_info(p : tabstractprocdef; varargspara:tvarargsparalist):longint;override;
procedure createtempparaloc(list: TAsmList;calloption : tproccalloption;parasym : tparavarsym;can_use_final_stack_loc : boolean;var cgpara:TCGPara);override;
@@ -285,8 +289,29 @@ unit cpupara;
result:=[0..first_mm_imreg-1];
end;
-
-
+ procedure ti386paramanager.get_para_regoff(proccalloption: tproccalloption; paraloc: pcgparalocation; out reg: Byte; out off: LongInt);
+ var
+ I : SizeInt;
+ begin
+ with paraloc^ do
+ case loc of
+ LOC_REGISTER:
+ begin
+ for I := 0 to high(parasupregs) do
+ if getsupreg(register)=parasupregs[I] then
+ begin
+ reg:=I;
+ break;
+ end;
+ off:=0;
+ end;
+ LOC_REFERENCE:
+ begin
+ reg:=255;
+ off:=reference.offset;
+ end;
+ end;
+ end;
function ti386paramanager.get_funcretloc(p : tabstractprocdef; side: tcallercallee; forcetempdef: tdef): TCGPara;
var
--
1.9.5.msysgit.0
-------------- next part --------------
program TestInterfaceRTTI;
{$mode objfpc}{$H+}
uses
{$IFDEF UNIX}{$IFDEF UseCThreads}
cthreads,
{$ENDIF}{$ENDIF}
classes, typinfo, variants;
type
TNumber = integer;
TNewNumber = type integer;
TIntegerArray = array of integer;
TNormalClass = class(TObject);
TSetOfByte = set of byte;
TEnum = (enOne, enTwo, enThree);
IMyMPInterface = interface['{AA503475-0187-4108-8E27-41475F4EF818}']
procedure TestRegister(A: integer; var B: string); register;
procedure TestStdCall(LongParaName: TObject; const B: string; var C: integer; out D: byte); stdcall;
procedure TestSafeCall(out R: integer); safecall;
function Number: TNumber; cdecl;
function NewNumber: TNewNumber; cdecl;
function AsString: string; pascal;
function AsString2: string; safecall;
procedure A2(const A: TIntegerArray);
procedure OkParam1(Value: TSetOfByte);
procedure OkParam2(Value: TEnum);
procedure OkParam3(Value: Variant);
procedure OkParam4(Value: TNormalClass);
function OkReturn1: shortstring;
function OkReturn2: TObject;
function OkReturn3: IInterface;
function OkReturn4: TSetOfByte;
function OkReturn5: TNormalClass;
function OkReturn6: TEnum;
function OkReturn7: TClass;
function OkReturn8: Pointer;
function OkReturn9: PChar;
function OkReturn10: TIntegerArray;
end;
function Skip(Value: PShortstring): pointer; overload;
begin
Result := Value;
Inc(PChar(Result), SizeOf(Value^[0]) + Length(Value^));
end;
function checkParam(
var p : Pointer;
const aName : ShortString;
aFlags : TParamFlags;
aType : PTypeInfo;
aReg : Byte;
aOff : LongInt) : Boolean;
begin
with PVmtMethodParam(p)^ do
begin
if aName <> Name then
exit(false);
if aFlags <> Flags then
exit(false);
if aType <> ParamType then
exit(false);
if aReg <> ParReg then
exit(false);
if aOff <> ParOff then
exit(false);
p := Skip(@Name);
end;
result := true;
end;
function checkMethod(
var p : Pointer;
const aName : ShortString;
aMethodCC : TCallConv;
aResultType : PTypeInfo;
aStackSize : Word;
paramNames : array of ShortString;
paramFlags : array of TParamFlags;
paramTypes : array of PTypeInfo;
paramReg : array of Byte;
paramOff : array of LongInt) : Boolean;
var
I : SizeInt;
begin
if aName <> PShortString(p)^ then
exit(false);
p := Skip(p);
if 3 <> PByte(p)^ then
exit(false);
inc(p, sizeOf(Byte));
if aMethodCC <> PCallConv(p)^ then
exit(false);
inc(p, sizeOf(TCallConv));
if aResultType <> PPTypeInfo(p)^ then
exit(false);
inc(p, sizeOf(PTypeInfo));
if aStackSize <> PWord(p)^ then
exit(false);
inc(p, sizeOf(Word));
if length(paramNames) <> PByte(p)^ then
exit(false);
inc(p, sizeOf(Byte));
for I := 0 to high(paramNames) do
if not checkParam(p, paramNames[I], paramFlags[I], paramTypes[I], paramReg[I], paramOff[I]) then
exit(false);
result := true;
end;
function getMethodIntfTable(aTypeInfo : PTypeInfo) : PIntfMethodTable;
var
td : PTypeData;
p : Pointer;
propCount : SmallInt;
I : SizeInt;
begin
td := GetTypeData(aTypeInfo);
if aTypeInfo^.Kind = tkInterface then
p := skip(@td^.IntfUnit)
else
p := skip(@td^.RawIntfUnit);
propCount := PSmallInt(p)^;
inc(p, sizeOf(SmallInt));
for I := 0 to propCount - 1 do
p := skip(@(PPropInfo(p)^.Name));
result := p;
end;
var
count : SizeInt;
p : Pointer;
begin
p := getMethodIntfTable(TypeInfo(IMyMPInterface));
count := PIntfMethodTable(p)^.Count;
if count <> 22 then
halt(-1);
inc(p, SizeOf(TIntfMethodTable));
//procedure TestRegister(A: integer; var B: string); register;
if not checkMethod(p, 'TestRegister', TCallConv.ccReg, nil, 0,
['$self','A','B'],
[[TParamFlag.pfAddress],[],[TParamFlag.pfVar]],
[TypeInfo(IMyMPInterface), TypeInfo(Integer), TypeInfo(String)],
[0, 1, 2],
[0, 0, 0]
) then
halt(-2);
//procedure TestStdCall(LongParaName: TObject; const B: string; var C: integer; out D: byte); stdcall;
if not checkMethod(p, 'TestStdCall', TCallConv.ccStdCall, nil, 20,
['$self','LongParaName','B', 'C', 'D'],
[[TParamFlag.pfAddress],[TParamFlag.pfAddress],[TParamFlag.pfConst],[TParamFlag.pfVar],[TParamFlag.pfOut]],
[TypeInfo(IMyMPInterface), TypeInfo(TObject), TypeInfo(string), TypeInfo(integer), TypeInfo(byte)],
[255, 255, 255, 255, 255],
[0, 4, 8, 12, 16]
) then
halt(-2);
//procedure TestSafeCall(out R: integer); safecall;
if not checkMethod(p, 'TestSafeCall', TCallConv.ccSafeCall, nil, 8,
['$self','R'],
[[TParamFlag.pfAddress],[TParamFlag.pfOut]],
[TypeInfo(IMyMPInterface), TypeInfo(integer)],
[255, 255],
[0, 4]
) then
halt(-3);
//function Number: TNumber; cdecl;
if not checkMethod(p, 'Number', TCallConv.ccCdecl, TypeInfo(TNumber), 4,
['$self'],
[[TParamFlag.pfAddress]],
[TypeInfo(IMyMPInterface)],
[255],
[0]
) then
halt(-4);
//function NewNumber: TNewNumber; cdecl;
if not checkMethod(p, 'NewNumber', TCallConv.ccCdecl, TypeInfo(TNewNumber), 4,
['$self'],
[[TParamFlag.pfAddress]],
[TypeInfo(IMyMPInterface)],
[255],
[0]
) then
halt(-5);
//function AsString: string; pascal;
if not checkMethod(p, 'AsString', TCallConv.ccPascal, TypeInfo(String), 8,
['$self'],
[[TParamFlag.pfAddress]],
[TypeInfo(IMyMPInterface)],
[255],
[4]
) then
halt(-6);
//function AsString2: string; safecall;
if not checkMethod(p, 'AsString2', TCallConv.ccSafeCall, TypeInfo(String), 8,
['$self'],
[[TParamFlag.pfAddress]],
[TypeInfo(IMyMPInterface)],
[255],
[0]
) then
halt(-7);
//procedure A2(const A: TIntegerArray);
if not checkMethod(p, 'A2', TCallConv.ccReg, nil, 4,
['$self', 'A'],
[[TParamFlag.pfAddress], [TParamFlag.pfConst]],
[TypeInfo(IMyMPInterface), TypeInfo(TIntegerArray)],
[0, 255],
[0, 0]
) then
halt(-8);
//procedure OkParam1(Value: TSetOfByte);
if not checkMethod(p, 'OkParam1', TCallConv.ccReg, nil, 0,
['$self', 'Value'],
[[TParamFlag.pfAddress], []],
[TypeInfo(IMyMPInterface), TypeInfo(TSetOfByte)],
[0, 1],
[0, 0]
) then
halt(-9);
//procedure OkParam2(Value: TEnum);
if not checkMethod(p, 'OkParam2', TCallConv.ccReg, nil, 0,
['$self', 'Value'],
[[TParamFlag.pfAddress], []],
[TypeInfo(IMyMPInterface), TypeInfo(TEnum)],
[0, 1],
[0, 0]
) then
halt(-10);
//procedure OkParam3(Value: Variant);
if not checkMethod(p, 'OkParam3', TCallConv.ccReg, nil, 0,
['$self', 'Value'],
[[TParamFlag.pfAddress], []],
[TypeInfo(IMyMPInterface), TypeInfo(Variant)],
[0, 1],
[0, 0]
) then
halt(-11);
//procedure OkParam4(Value: TNormalClass);
if not checkMethod(p, 'OkParam4', TCallConv.ccReg, nil, 0,
['$self', 'Value'],
[[TParamFlag.pfAddress], [TParamFlag.pfAddress]],
[TypeInfo(IMyMPInterface), TypeInfo(TNormalClass)],
[0, 1],
[0, 0]
) then
halt(-12);
//function OkReturn1: shortstring;
if not checkMethod(p, 'OkReturn1', TCallConv.ccReg, TypeInfo(shortstring), 0,
['$self'],
[[TParamFlag.pfAddress]],
[TypeInfo(IMyMPInterface)],
[0],
[0]
) then
halt(-13);
//function OkReturn2: TObject;
if not checkMethod(p, 'OkReturn2', TCallConv.ccReg, TypeInfo(TObject), 0,
['$self'],
[[TParamFlag.pfAddress]],
[TypeInfo(IMyMPInterface)],
[0],
[0]
) then
halt(-14);
//function OkReturn3: IInterface;
if not checkMethod(p, 'OkReturn3', TCallConv.ccReg, TypeInfo(IInterface), 0,
['$self'],
[[TParamFlag.pfAddress]],
[TypeInfo(IMyMPInterface)],
[0],
[0]
) then
halt(-15);
//function OkReturn4: TSetOfByte;
if not checkMethod(p, 'OkReturn4', TCallConv.ccReg, TypeInfo(TSetOfByte), 0,
['$self'],
[[TParamFlag.pfAddress]],
[TypeInfo(IMyMPInterface)],
[0],
[0]
) then
halt(-16);
//function OkReturn5: TNormalClass;
if not checkMethod(p, 'OkReturn5', TCallConv.ccReg, TypeInfo(TNormalClass), 0,
['$self'],
[[TParamFlag.pfAddress]],
[TypeInfo(IMyMPInterface)],
[0],
[0]
) then
halt(-17);
//function OkReturn6: TEnum;
if not checkMethod(p, 'OkReturn6', TCallConv.ccReg, TypeInfo(TEnum), 0,
['$self'],
[[TParamFlag.pfAddress]],
[TypeInfo(IMyMPInterface)],
[0],
[0]
) then
halt(-18);
//function OkReturn7: TClass;
if not checkMethod(p, 'OkReturn7', TCallConv.ccReg, TypeInfo(TClass), 0,
['$self'],
[[TParamFlag.pfAddress]],
[TypeInfo(IMyMPInterface)],
[0],
[0]
) then
halt(-19);
//function OkReturn8: Pointer;
if not checkMethod(p, 'OkReturn8', TCallConv.ccReg, TypeInfo(Pointer), 0,
['$self'],
[[TParamFlag.pfAddress]],
[TypeInfo(IMyMPInterface)],
[0],
[0]
) then
halt(-20);
//function OkReturn9: PChar;
if not checkMethod(p, 'OkReturn9', TCallConv.ccReg, TypeInfo(PChar), 0,
['$self'],
[[TParamFlag.pfAddress]],
[TypeInfo(IMyMPInterface)],
[0],
[0]
) then
halt(-21);
//function OkReturn10: TIntegerArray;
if not checkMethod(p, 'OkReturn10', TCallConv.ccReg, TypeInfo(TIntegerArray), 0,
['$self'],
[[TParamFlag.pfAddress]],
[TypeInfo(IMyMPInterface)],
[0],
[0]
) then
halt(-22);
writeln('Sucess');
readln;
end.
More information about the fpc-devel
mailing list