* first partially working implementation of variant com invoking

git-svn-id: trunk@5247 -

.gitattributes

@@ -4002,6 +4002,7 @@ packages/extra/winunits/Makefile svneol=native#text/plain
 packages/extra/winunits/Makefile.fpc svneol=native#text/plain
 packages/extra/winunits/activex.pp svneol=native#text/plain
 packages/extra/winunits/buildjwa.pp svneol=native#text/plain
+packages/extra/winunits/comconst.pp svneol=native#text/plain
 packages/extra/winunits/commctrl.pp svneol=native#text/plain
 packages/extra/winunits/comobj.pp svneol=native#text/plain
 packages/extra/winunits/examples/testver.pp svneol=native#text/plain

compiler/htypechk.pas

@@ -1235,6 +1235,12 @@ implementation
                     CGMessagePos(hp.fileinfo,type_e_variable_id_expected);
                  exit;
                end;
+             dataconstn:
+               begin
+                 { only created internally, so no additional checks necessary }
+                 result:=true;
+                 exit;
+               end;
              loadn :
                begin
                  case tloadnode(hp).symtableentry.typ of

compiler/ncal.pas

@@ -171,7 +171,7 @@ interface
        tcallparanodeclass = class of tcallparanode;
 
     function reverseparameters(p: tcallparanode): tcallparanode;
-    function translate_vardisp_call(p1,p2 : tnode) : tnode;
+    function translate_vardisp_call(p1,p2 : tnode;methodname : ansistring) : tnode;
 
     var
       ccallnode : tcallnodeclass;
@@ -223,7 +223,7 @@ implementation
       end;
 
 
-    function translate_vardisp_call(p1,p2 : tnode) : tnode;
+    function translate_vardisp_call(p1,p2 : tnode;methodname : ansistring) : tnode;
       const
         DISPATCH_METHOD = $1;
         DISPATCH_PROPERTYGET = $2;
@@ -242,21 +242,32 @@ implementation
         paracount : longint;
         vardatadef,
         pvardatadef : tdef;
+        dispatchbyref : boolean;
 
         calldesc : packed record
             calltype,argcount,namedargcount : byte;
+            { size of argtypes is unknown at compile time
+              so this is basically a dummy }
             argtypes : array[0..255] of byte;
+            { argtypes is followed by method name
+              names of named parameters, each being
+              a zero terminated string
+            }
         end;
         names : ansistring;
 
       procedure increase_paramssize;
         begin
+          { for now we pass everything by reference
           case para.value.resultdef.typ of
             variantdef:
               inc(paramssize,para.value.resultdef.size);
             else
+          }
               inc(paramssize,sizeof(voidpointertype.size ));
+          {
           end;
+          }
         end;
 
       begin
@@ -318,6 +329,7 @@ implementation
         { build up parameters and description }
         para:=tcallparanode(p2);
         currargpos:=0;
+        paramssize:=0;
         while assigned(para) do
           begin
             if assigned(para.parametername) then
@@ -327,14 +339,25 @@ implementation
                 else
                   internalerror(200611041);
               end;
+
+            dispatchbyref:=para.value.resultdef.typ in [stringdef];
             { assign the argument/parameter to the temporary location }
+
             if para.value.nodetype<>nothingn then
               addstatement(statements,cassignmentnode.create(
                 ctypeconvnode.create_internal(cderefnode.create(caddnode.create(addn,
                   caddrnode.create(ctemprefnode.create(params)),
                   cordconstnode.create(paramssize,ptrinttype,false)
-                )),para.value.resultdef),
-                para.value));
+                )),voidpointertype),
+                ctypeconvnode.create_internal(para.value,voidpointertype)));
+
+            if is_ansistring(para.value.resultdef) then
+              calldesc.argtypes[currargpos]:=varStrArg
+            else
+              calldesc.argtypes[currargpos]:=para.value.resultdef.getvardef;
+
+            if dispatchbyref then
+              calldesc.argtypes[currargpos]:=calldesc.argtypes[currargpos] or $80;
 
             increase_paramssize;
 
@@ -343,10 +366,15 @@ implementation
             para:=tcallparanode(para.nextpara);
           end;
 
+//        typecheckpass(statements);
+//        printnode(output,statements);
+
         { old argument list skeleton isn't needed anymore }
         p2.free;
 
-        calldescnode.append(calldesc,4+calldesc.argcount);
+        calldescnode.append(calldesc,3+calldesc.argcount);
+        methodname:=methodname+#0;
+        calldescnode.append(pointer(methodname)^,length(methodname));
         calldescnode.append(pointer(names)^,length(names));
 
         { actual call }
@@ -356,7 +384,7 @@ implementation
         addstatement(statements,ccallnode.createintern('fpc_dispinvoke_variant',
           { parameters are passed always reverted, i.e. the last comes first }
           ccallparanode.create(caddrnode.create(ctemprefnode.create(params)),
-          ccallparanode.create(calldescnode,
+          ccallparanode.create(caddrnode.create(calldescnode),
           ccallparanode.create(ctypeconvnode.create_internal(p1,vardatadef),
           ccallparanode.create(ctypeconvnode.create_internal(caddrnode.create(
               ctemprefnode.create(result_data)

compiler/ncnv.pas

@@ -1221,10 +1221,16 @@ implementation
 
     function ttypeconvnode.typecheck_variant_to_interface : tnode;
       begin
-        result := ccallnode.createinternres(
-          'fpc_variant_to_interface',
-            ccallparanode.create(left,nil)
-          ,resultdef);
+        if tobjectdef(resultdef).is_related(tobjectdef(search_system_type('IDISPATCH').typedef)) then
+          result := ccallnode.createinternres(
+            'fpc_variant_to_idispatch',
+              ccallparanode.create(left,nil)
+            ,resultdef)
+        else
+          result := ccallnode.createinternres(
+            'fpc_variant_to_interface',
+              ccallparanode.create(left,nil)
+            ,resultdef);
         typecheckpass(result);
         left:=nil;
       end;
@@ -1232,10 +1238,16 @@ implementation
 
     function ttypeconvnode.typecheck_interface_to_variant : tnode;
       begin
-        result := ccallnode.createinternres(
-          'fpc_interface_to_variant',
-            ccallparanode.create(left,nil)
-          ,resultdef);
+        if tobjectdef(left.resultdef).is_related(tobjectdef(search_system_type('IDISPATCH').typedef)) then
+          result := ccallnode.createinternres(
+            'fpc_idispatch_to_variant',
+              ccallparanode.create(left,nil)
+            ,resultdef)
+        else
+          result := ccallnode.createinternres(
+            'fpc_interface_to_variant',
+              ccallparanode.create(left,nil)
+            ,resultdef);
         typecheckpass(result);
         left:=nil;
       end;

compiler/options.pas

@@ -2182,7 +2182,8 @@ begin
     exclude(init_settings.globalswitches,cs_link_strip);
 
   { force fpu emulation on arm/wince and arm/gba }
-  if target_info.system in [system_arm_wince,system_arm_gba,system_m68k_amiga] then
+  if target_info.system in [system_arm_wince,system_arm_gba,system_m68k_amiga,
+    system_m68k_linux] then
     include(init_settings.moduleswitches,cs_fp_emulation);
 
   { Section smartlinking conflicts with import sections on Windows }

compiler/pexpr.pas

@@ -1860,6 +1860,9 @@ implementation
           srsym  : tsym;
           srsymtable : TSymtable;
           classh     : tobjectdef;
+          { shouldn't be used that often, so the extra overhead is ok to save
+            stack space }
+          dispatchstring : ansistring;
         label
           skipreckklammercheck;
         begin
@@ -2049,12 +2052,13 @@ implementation
                            { dispatch call? }
                            if token=_ID then
                              begin
+                               dispatchstring:=orgpattern;
                                consume(_ID);
                                if try_to_consume(_LKLAMMER) then
                                  begin
                                    p2:=parse_paras(false,true,_RKLAMMER);
                                    consume(_RKLAMMER);
-                                   p1:=translate_vardisp_call(p1,p2);
+                                   p1:=translate_vardisp_call(p1,p2,dispatchstring);
                                  end
                                else
                                  p2:=nil;

compiler/symdef.pas

@@ -507,6 +507,7 @@ interface
           function  is_publishable : boolean;override;
           function alignment : shortint;override;
           function  needs_inittable : boolean;override;
+          function  getvardef:longint;override;
        end;
 
        tenumdef = class(tstoreddef)
@@ -1215,6 +1216,15 @@ implementation
       end;
 
 
+    function tstringdef.getvardef : longint;
+      const
+        vardef : array[tstringtype] of longint = (
+          varUndefined,varUndefined,varString,varOleStr);
+      begin
+        result:=vardef[stringtype];
+      end;
+
+
     function tstringdef.alignment : shortint;
       begin
         case stringtype of

packages/extra/winunits/activex.pp

@@ -1400,21 +1400,27 @@ TYPE
                                    cNamedArgs        : UINT;
                                    End;
   DISPPARAMS                    = tagDISPPARAMS;
+  TDispParams                   = tagDISPPARAMS;
+  PDispParams                   = ^TDispParams;
+
+  PExcepInfo                    = ^TExcepInfo;
+  TFNDeferredFillIn             = function(info : PExcepInfo): HRESULT;stdcall;
   tagEXCEPINFO                  = Record
                                     wCode,                         // An error code describing the error.
                                     wReserved      : Word;
                                     Source,                        // A source of the exception
                                     Description,                   // A description of the error
                                     HelpFile       : WideString;   // Fully qualified drive, path, and file name
-                                    dwHelpContext  : DWord;    // help context of topic within the help file
+                                    dwHelpContext  : ULONG;        // help context of topic within the help file
                                                                    // We can use ULONG_PTR here, because EXCEPINFO is marshalled by RPC
                                                                    // RPC will marshal pfnDeferredFillIn.
-                                    pvReserved,
-                                    pfnDeferredFillIn : pULONG;
+                                    pvReserved     : pointer;
+                                    pfnDeferredFillIn : TFNDeferredFillIn;
                                     SCODE          : scode;
                                     End;
 
   EXCEPINFO                     =  tagEXCEPINFO;
+  TExcepInfo                    =  tagEXCEPINFO;
 
   tagTYPEATTR                   = Record
                                    GUID            : Tguid;       // the GUID of the TypeInfo
@@ -3286,7 +3292,16 @@ type
   function SetErrorInfo(dwReserved:ULONG;errinfo:IErrorInfo):HResult;stdcall; external 'ole32.dll' name 'SetErrorInfo';
   function GetErrorInfo(dwReserved:ULONG;out errinfo:IErrorInfo):HResult;stdcall; external 'ole32.dll' name 'GetErrorInfo';
   function CreateErrorInfo(out errinfo:ICreateErrorInfo):HResult;stdcall; external 'ole32.dll' name 'CreateErrorInfo';
-
+  
+  const
+    oleaut32dll   = 'oleaut32.dll';
+    
+  function  SysAllocString(psz: pointer): Integer; external oleaut32dll name 'SysAllocString';
+  function  SysAllocStringLen(psz: pointer; len:dword): Integer; external oleaut32dll name 'SysAllocStringLen';
+  procedure SysFreeString(bstr:pointer); external oleaut32dll name 'SysFreeString';
+  function  SysStringLen(bstr:pointer):UINT; external oleaut32dll name 'SysStringLen';
+  function  SysReAllocString(var bstr:pointer;psz: pointer): Integer; external oleaut32dll name 'SysReAllocString';
+  function  SysReAllocStringLen(var bstr:pointer;psz: pointer; len:dword): Integer; external oleaut32dll name 'SysReAllocStringLen';
 
 implementation
 

packages/extra/winunits/comconst.pp

@@ -0,0 +1,29 @@
+{
+    This file is part of the Free Pascal run time library.
+    Copyright (c) 2006 by Florian Klaempfl
+    member of the Free Pascal development team.
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+ **********************************************************************}
+{$mode objfpc}
+{$H+}
+{$inline on}
+unit comconst;
+
+  interface
+
+    resourcestring
+      SNoMethod = 'Method ''%s'' is not supported by automation object';
+      SOleError = 'OLE error %.8x';
+      SVarNotObject = 'Variant does not reference an automation object';
+
+  implementation
+
+end.
+

packages/extra/winunits/comobj.pp

@@ -1,6 +1,6 @@
 {
     This file is part of the Free Pascal run time library.
-    Copyright (c) 2002 by Florian Klaempfl
+    Copyright (c) 2006 by Florian Klaempfl
     member of the Free Pascal development team.
 
     See the file COPYING.FPC, included in this distribution,
@@ -106,10 +106,14 @@ unit comobj;
 
     function ProgIDToClassID(const id : string) : TGUID;
 
-  implementation
+    procedure DispatchInvoke(const Dispatch: IDispatch; CallDesc: PCallDesc;
+       DispIDs: PDispIDList; Params: Pointer; Result: PVariant);
+    procedure DispatchInvokeError(Status: HRESULT; const ExceptInfo: TExcepInfo);
+
+implementation
 
     uses
-       windows;
+      Windows,Types,Variants,ComConst;
 
     constructor EOleSysError.Create(const Msg: string; aErrorCode: HRESULT; aHelpContext: Integer);
       var
@@ -211,6 +215,224 @@ unit comobj;
      end;
 
 
+    procedure DispatchInvokeError(Status: HRESULT; const ExceptInfo: TExcepInfo);
+      begin
+        if Status=DISP_E_EXCEPTION then
+          raise EOleException.Create(ExceptInfo.Description,ExceptInfo.scode,ExceptInfo.Source,
+            ExceptInfo.HelpFile,ExceptInfo.dwHelpContext)
+        else
+          raise EOleSysError.Create('',Status,0);
+      end;
+
+{$define DEBUG_COMDISPATCH}
+    procedure DispatchInvoke(const Dispatch: IDispatch; CallDesc: PCallDesc;
+      DispIDs: PDispIDList; Params: Pointer; Result: PVariant);
+
+      var
+        { we can't pass pascal ansistrings to COM routines so we've to convert them
+          to/from widestring. This array contains the mapping to do so
+        }
+        StringMap : array[0..255] of record passtr : pansistring; comstr : pwidechar; end;
+        invokekind,
+        i : longint;
+        invokeresult : HResult;
+        exceptioninfo : TExcepInfo;
+        dispparams : TDispParams;
+        NextString : SizeInt;
+        Arguments : array[0..255] of TVarData;
+        CurrType : byte;
+        MethodID : TDispID;
+      begin
+        NextString:=0;
+        fillchar(dispparams,sizeof(dispparams),0);
+        try
+{$ifdef DEBUG_COMDISPATCH}
+          writeln('Got ',CallDesc^.ArgCount,' arguments');
+{$endif DEBUG_COMDISPATCH}
+          { copy and prepare arguments }
+          for i:=0 to CallDesc^.ArgCount-1 do
+            begin
+              { get plain type }
+              CurrType:=CallDesc^.ArgTypes[i] and $3f;
+              { by reference? }
+              if (CallDesc^.ArgTypes[i] and $80)<>0 then
+                begin
+                  case CurrType of
+                    varStrArg:
+                      begin
+{$ifdef DEBUG_COMDISPATCH}
+                        writeln('Translating var ansistring argument ',PString(Params^)^);
+{$endif DEBUG_COMDISPATCH}
+                        StringMap[NextString].ComStr:=StringToOleStr(PString(Params^)^);
+                        StringMap[NextString].PasStr:=PString(Params^);
+                        Arguments[i].VType:=varOleStr or varByRef;
+                        Arguments[i].VPointer:=StringMap[NextString].ComStr;
+                        inc(NextString);
+                        inc(PPointer(Params));
+                      end;
+                    varVariant:
+{$ifdef DEBUG_COMDISPATCH}
+                      writeln('Unimplemented ref variant dispatch');
+{$endif DEBUG_COMDISPATCH}
+                    else
+                      begin
+                        writeln('Got ref argument with type ',CurrType);
+                        Arguments[i].VType:=CurrType or VarByRef;
+                        Arguments[i].VPointer:=PPointer(Params)^;
+                        inc(PPointer(Params));
+                      end;
+                  end
+                end
+              else
+                case CurrType of
+                  varStrArg:
+                    begin
+{$ifdef DEBUG_COMDISPATCH}
+                      writeln('Translating ansistring argument ',PString(Params)^);
+{$endif DEBUG_COMDISPATCH}
+                      StringMap[NextString].ComStr:=StringToOleStr(PString(Params)^);
+                      StringMap[NextString].PasStr:=nil;
+                      Arguments[i].VType:=varOleStr;
+                      Arguments[i].VPointer:=StringMap[NextString].ComStr;
+                      inc(NextString);
+                      inc(PPointer(Params));
+                    end;
+
+                  varVariant:
+                    begin
+{$ifdef DEBUG_COMDISPATCH}
+                      writeln('Unimplemented variant dispatch');
+{$endif DEBUG_COMDISPATCH}
+                    end;
+                  varCurrency,
+                  varDouble,
+                  VarDate:
+                    begin
+{$ifdef DEBUG_COMDISPATCH}
+                      writeln('Got 8 byte float argument');
+{$endif DEBUG_COMDISPATCH}
+                      Arguments[i].VType:=CurrType;
+                      move(PPointer(Params)^,Arguments[i].VDouble,sizeof(Double));
+                      inc(PDouble(Params));
+                    end;
+                  else
+                    begin
+{$ifdef DEBUG_COMDISPATCH}
+                      writeln('Got argument with type ',CurrType);
+{$endif DEBUG_COMDISPATCH}
+                      Arguments[i].VType:=CurrType;
+                      Arguments[i].VPointer:=PPointer(Params)^;
+                      inc(PPointer(Params));
+                    end;
+                end;
+            end;
+
+          { finally prepare the call }
+          with DispParams do
+            begin
+              rgvarg:=@Arguments;
+              rgdispidNamedArgs:=@DispIDs[1];
+              cArgs:=CallDesc^.ArgCount;
+              cNamedArgs:=CallDesc^.NamedArgCount;
+            end;
+          InvokeKind:=CallDesc^.CallType;
+          MethodID:=DispIDs^[0];
+{$ifdef DEBUG_COMDISPATCH}
+          writeln('MethodID: ',MethodID);
+{$endif DEBUG_COMDISPATCH}
+          { do the call and check the result }
+          invokeresult:=Dispatch.Invoke(MethodID,GUID_NULL,0,InvokeKind,DispParams,result,@exceptioninfo,nil);;
+          if invokeresult<>0 then
+            DispatchInvokeError(invokeresult,exceptioninfo);
+
+          { translate strings back }
+          for i:=0 to NextString-1 do
+            if assigned(StringMap[i].passtr) then
+              OleStrToStrVar(StringMap[i].comstr,StringMap[i].passtr^);
+        finally
+          for i:=0 to NextString-1 do
+            SysFreeString(StringMap[i].ComStr);
+        end;
+      end;
+
+
+    procedure SearchIDs(const DispatchInterface : IDispatch; Names: PChar;
+      Count: Integer; IDs: PDispIDList);
+      var
+      	res : HRESULT;
+      	NamesArray : ^PWideChar;
+      	NamesData : PWideChar;
+        NameCount,
+      	NameLen,
+      	NewNameLen,
+        CurrentNameDataUsed,
+      	CurrentNameDataSize : SizeInt;
+      	i : longint;
+      begin
+      	getmem(NamesArray,Count*sizeof(PWideChar));
+      	CurrentNameDataSize:=256;
+      	CurrentNameDataUsed:=0;
+      	getmem(NamesData,CurrentNameDataSize*2);
+        NameCount:=0;
+{$ifdef DEBUG_COMDISPATCH}
+        writeln('SearchIDs: Searching ',Count,' IDs');
+{$endif DEBUG_COMDISPATCH}
+      	for i:=1 to Count do
+      	  begin
+       	    NameLen:=strlen(Names);
+{$ifdef DEBUG_COMDISPATCH}
+            writeln('SearchIDs: Original name: ',Names,' Len: ',NameLen);
+{$endif DEBUG_COMDISPATCH}
+      	    NewNameLen:=MultiByteToWideChar(0,0,Names,NameLen,nil,0)+1;
+      	    if CurrentNameDataUsed+NewNameLen*2>CurrentNameDataSize then
+      	      begin
+      	      	inc(CurrentNameDataSize,256);
+      	        reallocmem(NamesData,CurrentNameDataSize*2);
+      	      end;
+      	    NamesArray[i-1]:=@NamesData[CurrentNameDataUsed];
+      	    MultiByteToWideChar(0,0,Names,NameLen,@NamesData[CurrentNameDataUsed],NewNameLen);
+      	    NamesData[CurrentNameDataUsed+NewNameLen-1]:=#0;
+{$ifdef DEBUG_COMDISPATCH}
+            { we should write a widestring here writeln('SearchIDs: Translated name: ',NamesData[CurrentNameDataUsed]); }
+{$endif DEBUG_COMDISPATCH}
+      	    inc(CurrentNameDataUsed,NewNameLen);
+      	    inc(Names,NameLen+1);
+            inc(NameCount);
+      	  end;
+      	res:=DispatchInterface.GetIDsOfNames(GUID_NULL,NamesArray,NameCount,GetThreadLocale,IDs);
+      	if res=DISP_E_UNKNOWNNAME then
+      	  raise EOleError.createresfmt(@snomethod,[names])
+      	else
+      	  OleCheck(res);
+      	freemem(NamesArray);
+      	freemem(NamesData);
+      end;
+
+
+    procedure ComObjDispatchInvoke(dest : PVariant;const source : Variant;
+        calldesc : pcalldesc;params : pointer);cdecl;
+      var
+      	dispatchinterface : pointer;
+      	ids : array[0..255] of longint;
+      begin
+{$ifdef DEBUG_COMDISPATCH}
+        writeln('ComObjDispatchInvoke called');
+        writeln('ComObjDispatchInvoke: CallDesc^.ArgCount = ',CallDesc^.ArgCount);
+{$endif DEBUG_COMDISPATCH}
+      	if tvardata(source).vtype=VarDispatch then
+      	  dispatchinterface:=tvardata(source).vdispatch
+      	else if tvardata(source).vtype=(VarDispatch or VarByRef) then
+      	  dispatchinterface:=pvardata(tvardata(source).vpointer)^.vdispatch
+      	else
+      	  raise eoleerror.createres(@SVarNotObject);
+      	SearchIDs(IDispatch(dispatchinterface),@CallDesc^.ArgTypes[CallDesc^.ArgCount],
+          CallDesc^.NamedArgCount+1,@ids);
+      	if assigned(dest) then
+      	  VarClear(dest^);
+      	DispatchInvoke(IDispatch(dispatchinterface),calldesc,@ids,params,dest);
+      end;
+
+
 const
   Initialized : boolean = false;
 
@@ -218,7 +440,9 @@ initialization
   if not(IsLibrary) then
     Initialized:=Succeeded(CoInitialize(nil));
   SafeCallErrorProc:=@SafeCallErrorHandler;
+  VarDispProc:=@ComObjDispatchInvoke;
 finalization
+  VarDispProc:=nil;
   SafeCallErrorProc:=nil;
   if Initialized then
     CoUninitialize;

rtl/inc/compproc.inc

@@ -207,6 +207,8 @@ function fpc_variant_to_dynarray(const v : variant;typeinfo : pointer) : pointer
 function fpc_dynarray_to_variant(dynarr : pointer;typeinfo : pointer) : variant;compilerproc;
 function fpc_variant_to_interface(const v : variant) : iinterface;compilerproc;
 function fpc_interface_to_variant(const i : iinterface) : variant;compilerproc;
+function fpc_variant_to_idispatch(const v : variant) : idispatch;compilerproc;
+function fpc_idispatch_to_variant(const i : idispatch) : variant;compilerproc;
 procedure fpc_vararray_get(var d : variant;const s : variant;indices : psizeint;len : sizeint);compilerproc;
 procedure fpc_vararray_put(var d : variant;const s : variant;indices : psizeint;len : sizeint);compilerproc;
 procedure fpc_dispinvoke_variant(dest : pvardata;const source : tvardata;  calldesc : pcalldesc;params : pointer);compilerproc;

rtl/inc/variant.inc

@@ -143,6 +143,18 @@ function fpc_interface_to_variant(const i : iinterface) : variant;compilerproc;
   end;
 
 
+function fpc_variant_to_idispatch(const v : variant) : idispatch;compilerproc;
+  begin
+    variantmanager.vartodisp(result,v);
+  end;
+
+
+function fpc_idispatch_to_variant(const i : idispatch) : variant;compilerproc;
+  begin
+    variantmanager.varfromdisp(result,i);
+  end;
+
+
 procedure fpc_dispinvoke_variant(dest : pvardata;const source : tvardata; 
   calldesc : pcalldesc;params : pointer);
   begin