tests: test arguments passing for dispinterfaces

git-svn-id: trunk@14784 -

tests/test/tdispinterface2.pp

@@ -16,22 +16,40 @@ type
     property Disp1: integer;
     procedure Disp2;
     property Disp402: wordbool dispid 402;
+    procedure DispArg1(Arg: IUnknown);
+    procedure DispArg2(Arg: IDispatch);
+    procedure DispArg3(var Arg: wordbool);
   end;
 
 var
   cur_dispid: longint;
+  cur_argtype: byte;
 
 {$HINTS OFF}
-procedure DoDispCallByID(res : Pointer; const disp : IDispatch;desc : PDispDesc; params : Pointer);
-begin
-  if desc^.dispid <> cur_dispid then
-    halt(cur_dispid);
-end;
+  procedure DoDispCallByID(res: Pointer; const disp: IDispatch; desc: PDispDesc;
+    params: Pointer);
+  begin
+    if desc^.dispid <> cur_dispid then
+      halt(cur_dispid);
+  end;
+
+  procedure DoDispCallByIDArg(res: Pointer; const disp: IDispatch; desc: PDispDesc;
+    params: Pointer);
+  begin
+    if desc^.calldesc.argcount <> 1 then
+      halt(4);
+    if desc^.calldesc.argtypes[0] <> cur_argtype then
+      halt(cur_argtype);
+  end;
+
+
 {$HINTS ON}
 
 var
   II: IIE;
+  B: wordbool;
 begin
+  // check dispid values
   DispCallByIDProc := @DoDispCallByID;
   cur_dispid := 300;
   II.Disp300;
@@ -41,4 +59,13 @@ begin
   II.Disp2;
   cur_dispid := 402;
   II.Disp402 := True;
+  // check arguments
+  DispCallByIDProc := @DoDispCallByIDArg;
+  cur_argtype := varunknown;
+  II.DispArg1(nil);
+  cur_argtype := vardispatch;
+  II.DispArg2(nil);
+  cur_argtype := varboolean or $80;
+  B := False;
+  II.DispArg3(B);
 end.