* Improvements to Dispatch call handling:

  o All signed and unsigned ordinal types are made automatable.
  o Non-automatable types are rejected when parsing dispinterface declarations.
  o Simplified translate_disp_call() a bit.
  o translate_disp_call() now supports non-automatable parameters which can be typecasted to automatable ones. UnicodeString is not yet there, though.
  o Partially fixes #17904: parameters of Variant Dispatch calls are passed by reference when they can be mapped to a variable.

git-svn-id: trunk@16360 -

compiler/defutil.pas

@@ -526,6 +526,8 @@ implementation
            setdef:
              is_in_limit:=(tsetdef(def_from).setbase>=tsetdef(def_to).setbase) and
                           (tsetdef(def_from).setmax<=tsetdef(def_to).setmax);
+         else
+           is_in_limit:=false;
          end;
       end;
 
@@ -1033,21 +1035,21 @@ implementation
         end;
       end;
 
-
+    { In Windows 95 era, ordinals were restricted to [u8bit,s32bit,s16bit,bool16bit]
+      As of today, both signed and unsigned types from 8 to 64 bits are supported. }
     function is_automatable(p : tdef) : boolean;
       begin
         result:=false;
         case p.typ of
           orddef:
-            result:=torddef(p).ordtype in [u8bit,s32bit,s16bit,bool16bit];
+            result:=torddef(p).ordtype in [u8bit,s8bit,u16bit,s16bit,u32bit,s32bit,
+              u64bit,s64bit,bool16bit];
           floatdef:
             result:=tfloatdef(p).floattype in [s64currency,s64real,s32real];
           stringdef:
             result:=tstringdef(p).stringtype in [st_ansistring,st_widestring];
           variantdef:
             result:=true;
-          arraydef:
-            result:=(ado_IsConstString in tarraydef(p).arrayoptions);
           objectdef:
             result:=tobjectdef(p).objecttype in [odt_interfacecom,odt_dispinterface,odt_interfacecorba];
         end;

compiler/ncal.pas

@@ -221,7 +221,7 @@ interface
        tcallparanodeclass = class of tcallparanode;
 
     function reverseparameters(p: tcallparanode): tcallparanode;
-    function translate_disp_call(selfnode,parametersnode,putvalue : tnode;methodname : ansistring;dispid : longint;resultdef : tdef) : tnode;
+    function translate_disp_call(selfnode,parametersnode,putvalue : tnode;const methodname : ansistring;dispid : longint;resultdef : tdef) : tnode;
 
     var
       ccallnode : tcallnodeclass = tcallnode;
@@ -273,14 +273,17 @@ implementation
         reverseparameters:=hp1;
       end;
 
-
-    function translate_disp_call(selfnode,parametersnode,putvalue : tnode;methodname : ansistring;dispid : longint;resultdef : tdef) : tnode;
+    function translate_disp_call(selfnode,parametersnode,putvalue : tnode; const methodname : ansistring;dispid : longint;resultdef : tdef) : tnode;
       const
         DISPATCH_METHOD = $1;
         DISPATCH_PROPERTYGET = $2;
         DISPATCH_PROPERTYPUT = $4;
         DISPATCH_PROPERTYPUTREF = $8;
         DISPATCH_CONSTRUCT = $4000;
+
+        calltypes: array[Boolean] of byte = (
+          DISPATCH_METHOD, DISPATCH_PROPERTYPUT
+        );
       var
         statements : tstatementnode;
         result_data,
@@ -298,16 +301,6 @@ implementation
         useresult: boolean;
         restype: byte;
 
-        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;
         dispintfinvoke,
         variantdispatch : boolean;
@@ -316,7 +309,8 @@ implementation
         begin
           // !! This condition is subject to change, see Mantis #17904
           result:=(assigned(para.parasym) and (para.parasym.varspez in [vs_var,vs_out,vs_constref])) or
-                  (para.left.resultdef.typ in [variantdef]);
+                  (para.left.resultdef.typ in [variantdef]) or
+                  (variantdispatch and valid_for_var(para.left,false));
 
           if result then
             assign_type:=voidpointertype
@@ -353,7 +347,6 @@ implementation
         dispintfinvoke:=not(variantdispatch);
 
         result:=internalstatements(statements);
-        fillchar(calldesc,sizeof(calldesc),0);
 
         useresult := assigned(resultdef) and not is_void(resultdef);
         if useresult then
@@ -379,41 +372,31 @@ implementation
               continue;
             end;
             inc(paracount);
+            if assigned(para.parametername) then
+              inc(namedparacount);
 
             { insert some extra casts }
             if is_constintnode(para.left) and not(is_64bitint(para.left.resultdef)) then
-              begin
-                para.left:=ctypeconvnode.create_internal(para.left,s32inttype);
-                typecheckpass(para.left);
-              end
+              inserttypeconv_internal(para.left,s32inttype)
+
             else if para.left.nodetype=stringconstn then
-              begin
-                para.left:=ctypeconvnode.create_internal(para.left,cwidestringtype);
-                typecheckpass(para.left);
-              end
+              inserttypeconv_internal(para.left,cwidestringtype)
+
             { force automatable boolean type }
             else if is_boolean(para.left.resultdef) then
-              begin
-                para.left:=ctypeconvnode.create_internal(para.left,bool16type);
-                typecheckpass(para.left);
-              end
+              inserttypeconv_internal(para.left,bool16type)
+
             { force automatable float type }
             else if is_extended(para.left.resultdef)
                 and (current_settings.fputype<>fpu_none) then
-              begin
-                para.left:=ctypeconvnode.create_internal(para.left,s64floattype);
-                typecheckpass(para.left);
-              end;
+              inserttypeconv_internal(para.left,s64floattype)
 
-            if assigned(para.parametername) then
-              begin
-                typecheckpass(para.left);
-                inc(namedparacount);
-              end;
+            else if is_shortstring(para.left.resultdef) then
+              inserttypeconv_internal(para.left,cwidestringtype)
 
-            if para.left.nodetype<>nothingn then
-              if not is_automatable(para.left.resultdef) then
-                CGMessagePos1(para.left.fileinfo,type_e_not_automatable,para.left.resultdef.typename);
+            { skip this check if we've already typecasted to automatable type }
+            else if not is_automatable(para.left.resultdef) then
+              CGMessagePos1(para.left.fileinfo,type_e_not_automatable,para.left.resultdef.typename);
 
             { we've to know the parameter size to allocate the temp. space }
             is_byref_para(assignmenttype);
@@ -421,11 +404,6 @@ implementation
 
             para:=tcallparanode(para.nextpara);
           end;
-        if assigned(putvalue) then
-          calldesc.calltype:=DISPATCH_PROPERTYPUT
-        else
-          calldesc.calltype:=DISPATCH_METHOD;
-        calldesc.argcount:=paracount;
 
         { allocate space }
         params:=ctempcreatenode.create(voidtype,paramssize,tt_persistent,true);
@@ -442,8 +420,13 @@ implementation
             restype:=getvardef(resultdef)
           else
             restype:=0;
-          calldescnode.append(restype,sizeof(restype));
+          calldescnode.appendbyte(restype);
         end;
+
+        calldescnode.appendbyte(calltypes[assigned(putvalue)]);
+        calldescnode.appendbyte(paracount);
+        calldescnode.appendbyte(namedparacount);
+
         { build up parameters and description }
         para:=tcallparanode(parametersnode);
         currargpos:=0;
@@ -466,7 +449,7 @@ implementation
                   internalerror(200611041);
               end;
 
-            calldesc.argtypes[currargpos]:=getvardef(para.left.resultdef);
+            restype:=getvardef(para.left.resultdef);
 
             { assign the argument/parameter to the temporary location }
 
@@ -478,7 +461,7 @@ implementation
                     cordconstnode.create(qword(paramssize),ptruinttype,false)
                   )),voidpointertype),
                   ctypeconvnode.create_internal(caddrnode.create_internal(para.left),voidpointertype)));
-                calldesc.argtypes[currargpos]:=calldesc.argtypes[currargpos] or $80;
+                restype:=restype or $80;
               end
             else
               addstatement(statements,cassignmentnode.create(
@@ -489,6 +472,7 @@ implementation
                 ctypeconvnode.create_internal(para.left,assignmenttype)));
 
             inc(paramssize,assignmenttype.size);
+            calldescnode.appendbyte(restype);
 
             para.left:=nil;
             inc(currargpos);
@@ -498,8 +482,6 @@ implementation
         { old argument list skeleton isn't needed anymore }
         parametersnode.free;
 
-        calldescnode.append(calldesc,3+calldesc.argcount);
-
         pvardatadef:=tpointerdef(search_system_type('PVARDATA').typedef);
 
         if useresult then
@@ -509,8 +491,8 @@ implementation
 
         if variantdispatch then
           begin
-            methodname:=methodname+#0;
             calldescnode.append(pointer(methodname)^,length(methodname));
+            calldescnode.appendbyte(0);
             calldescnode.append(pointer(names)^,length(names));
 
             { actual call }

compiler/ncon.pas

@@ -46,6 +46,7 @@ interface
          function docompare(p: tnode) : boolean; override;
          procedure printnodedata(var t:text);override;
          procedure append(const d;len : aint);
+         procedure appendbyte(b : byte);
          procedure align(value : word);
        end;
        tdataconstnodeclass = class of tdataconstnode;
@@ -498,6 +499,11 @@ implementation
         data.write(d,len);
       end;
 
+    procedure tdataconstnode.appendbyte(b : byte);
+      begin
+        data.seek(data.size);
+        data.write(b,1);
+      end;
 
     procedure tdataconstnode.align(value : word);
       begin

compiler/pdecsub.pas

@@ -666,6 +666,11 @@ implementation
              not(varspez in [vs_out,vs_var]) then
             CGMessage(cg_e_file_must_call_by_reference);
 
+          { Dispinterfaces are restricted to using only automatable types }
+          if (pd.typ=procdef) and is_dispinterface(tprocdef(pd)._class) and
+             not is_automatable(hdef) then
+            Message1(type_e_not_automatable,hdef.typename);
+
           { univ cannot be used with types whose size is not known at compile
             time }
           if is_univ and
@@ -1055,6 +1060,10 @@ implementation
                              current_objectdef:=pd._class;
                            end;
                          single_type(pd.returndef,false,false);
+
+                         if is_dispinterface(pd._class) and not is_automatable(pd.returndef) then
+                           Message1(type_e_not_automatable,pd.returndef.typename);
+
                          if popclass then
                            begin
                              current_objectdef:=old_current_objectdef;

compiler/pdecvar.pas

@@ -420,6 +420,10 @@ implementation
            begin
               consume(_COLON);
               single_type(p.propdef,false,false);
+
+              if is_dispinterface(aclass) and not is_automatable(p.propdef) then
+                Message1(type_e_not_automatable,p.propdef.typename);
+
               if (idtoken=_INDEX) then
                 begin
                    consume(_INDEX);