Improvements to dispinterface property handling:

* Create implicit access methods, which hold type information for property parameters and allow parsing/typechecking occur the same way as for regular (non-dispinterface) properties.
+ Introduce separate proctypeoptions for property access methods. They are translated into correct dispatch call types and used to distinguish property access from regular method calls.
* Bump PPU version because new information has been introduced.
- Code specific to dispinterface properties in expression parser is no longer necessary, removed.
* Allow access to default property with [] for dispinterfaces.
+ Extended the test with basic correctness checks for property dispatching.

git-svn-id: trunk@16810 -

compiler/ncal.pas

@@ -2601,6 +2601,7 @@ implementation
         is_const : boolean;
         statements : tstatementnode;
         converted_result_data : ttempcreatenode;
+        calltype: tdispcalltype;
       label
         errorexit;
       begin
@@ -2994,6 +2995,12 @@ implementation
          { dispinterface methode invoke? }
          if assigned(methodpointer) and is_dispinterface(methodpointer.resultdef) then
            begin
+             case procdefinition.proctypeoption of
+               potype_propgetter: calltype:=dct_propget;
+               potype_propsetter: calltype:=dct_propput;
+             else
+               calltype:=dct_method;
+             end;
              { if the result is used, we've to insert a call to convert the type to be on the "safe side" }
              if (cnf_return_value_used in callnodeflags) and not is_void(procdefinition.returndef) then
                begin
@@ -3001,13 +3008,13 @@ implementation
                  converted_result_data:=ctempcreatenode.create(procdefinition.returndef,sizeof(procdefinition.returndef),tt_persistent,true);
                  addstatement(statements,converted_result_data);
                  addstatement(statements,cassignmentnode.create(ctemprefnode.create(converted_result_data),
-                   ctypeconvnode.create_internal(translate_disp_call(methodpointer,parameters,dct_method,'',tprocdef(procdefinition).dispid,procdefinition.returndef),
+                   ctypeconvnode.create_internal(translate_disp_call(methodpointer,parameters,calltype,'',tprocdef(procdefinition).dispid,procdefinition.returndef),
                    procdefinition.returndef)));
                  addstatement(statements,ctempdeletenode.create_normal_temp(converted_result_data));
                  addstatement(statements,ctemprefnode.create(converted_result_data));
                end
              else
-               result:=translate_disp_call(methodpointer,parameters,dct_method,'',tprocdef(procdefinition).dispid,voidtype);
+               result:=translate_disp_call(methodpointer,parameters,calltype,'',tprocdef(procdefinition).dispid,voidtype);
 
              { don't free reused nodes }
              methodpointer:=nil;

compiler/pdecvar.pas

@@ -241,13 +241,30 @@ implementation
                (ppo_hasparameters in p.propoptions);
           end;
 
-          procedure parse_dispinterface(p : tpropertysym);
+          procedure create_accessor_procsym(p: tpropertysym; pd: tprocdef; const prefix: string;
+              accesstype: tpropaccesslisttypes);
+            var
+              sym: tprocsym;
+            begin
+              handle_calling_convention(pd);
+              sym:=tprocsym.create(prefix+lower(p.realname));
+              symtablestack.top.insert(sym);
+              pd.procsym:=sym;
+              include(pd.procoptions,po_dispid);
+              include(pd.procoptions,po_global);
+              pd.visibility:=vis_private;
+              proc_add_definition(pd);
+              p.propaccesslist[accesstype].addsym(sl_call,sym);
+              p.propaccesslist[accesstype].procdef:=pd;
+            end;
+
+          procedure parse_dispinterface(p : tpropertysym; readpd,writepd: tprocdef;
+              var paranr: word);
             var
-              {procsym: tprocsym;
-              procdef: tprocdef;
-              valuepara: tparavarsym;}
               hasread, haswrite: boolean;
               pt: tnode;
+              hdispid: longint;
+              hparavs: tparavarsym;
             begin
               p.propaccesslist[palt_read].clear;
               p.propaccesslist[palt_write].clear;
@@ -260,12 +277,6 @@ implementation
               else if try_to_consume(_WRITEONLY) then
                 hasread:=false;
 
-              if hasread then
-                include(p.propoptions, ppo_dispid_read);
-
-              if haswrite then
-                include(p.propoptions, ppo_dispid_write);
-
               if try_to_consume(_DISPID) then
                 begin
                   pt:=comp_expr(true,false);
@@ -273,16 +284,39 @@ implementation
                     if (Tordconstnode(pt).value<int64(low(longint))) or (Tordconstnode(pt).value>int64(high(longint))) then
                       message(parser_e_range_check_error)
                     else
-                      p.dispid:=Tordconstnode(pt).value.svalue
+                      hdispid:=Tordconstnode(pt).value.svalue
                   else
                     Message(parser_e_dispid_must_be_ord_const);
                   pt.free;
                 end
               else
-                p.dispid:=tobjectdef(astruct).get_next_dispid;
+                hdispid:=tobjectdef(astruct).get_next_dispid;
+
+              { COM property is simply a pair of methods, tagged with 'propertyget'
+                and 'propertyset' flags (or a single method if access is restricted).
+                Creating these implicit accessor methods also allows the rest of compiler
+                to handle dispinterface properties the same way as regular ones. }
+              if hasread then
+                begin
+                  readpd.returndef:=p.propdef;
+                  readpd.dispid:=hdispid;
+                  readpd.proctypeoption:=potype_propgetter;
+                  create_accessor_procsym(p,readpd,'get$',palt_read);
+                end;
+              if haswrite then
+                begin
+                  { add an extra parameter, a placeholder of the value to set }
+                  inc(paranr);
+                  hparavs:=tparavarsym.create('$value',10*paranr,vs_value,p.propdef,[]);
+                  writepd.parast.insert(hparavs);
+
+                  writepd.proctypeoption:=potype_propsetter;
+                  writepd.dispid:=hdispid;
+                  create_accessor_procsym(p,writepd,'put$',palt_write);
+                end;
             end;
 
-          procedure add_index_parameter(var paranr: word; p: tpropertysym; readprocdef, writeprocdef: tprocvardef);
+          procedure add_index_parameter(var paranr: word; p: tpropertysym; readprocdef, writeprocdef: tprocdef);
             var
               hparavs: tparavarsym;
             begin
@@ -310,21 +344,23 @@ implementation
          found        : boolean;
          hreadparavs,
          hparavs      : tparavarsym;
-         storedprocdef,
+         storedprocdef: tprocvardef;
          readprocdef,
-         writeprocdef : tprocvardef;
+         writeprocdef : tprocdef;
       begin
-         { Generate temp procvardefs to search for matching read/write
+         { Generate temp procdefs to search for matching read/write
            procedures. the readprocdef will store all definitions }
          paranr:=0;
-         readprocdef:=tprocvardef.create(normal_function_level);
-         writeprocdef:=tprocvardef.create(normal_function_level);
+         readprocdef:=tprocdef.create(normal_function_level);
+         writeprocdef:=tprocdef.create(normal_function_level);
+
+         readprocdef.struct:=astruct;
+         writeprocdef.struct:=astruct;
 
-         { make them method pointers }
-         if assigned(astruct) and not is_classproperty then
+         if assigned(astruct) and is_classproperty then
            begin
-             include(readprocdef.procoptions,po_methodpointer);
-             include(writeprocdef.procoptions,po_methodpointer);
+             readprocdef.procoptions:=[po_staticmethod,po_classmethod];
+             writeprocdef.procoptions:=[po_staticmethod,po_classmethod];
            end;
 
          if token<>_ID then
@@ -577,7 +613,7 @@ implementation
                end;
            end
          else
-           parse_dispinterface(p);
+           parse_dispinterface(p,readprocdef,writeprocdef,paranr);
 
          { stored is not allowed for dispinterfaces, records or class properties }
          if assigned(astruct) and not(is_dispinterface(astruct) or is_record(astruct)) and not is_classproperty then
@@ -835,9 +871,11 @@ implementation
                message1(parser_e_implements_uses_non_implemented_interface,def.typename);
          end;
 
-         { remove temporary procvardefs }
-         readprocdef.owner.deletedef(readprocdef);
-         writeprocdef.owner.deletedef(writeprocdef);
+         { remove unneeded procdefs }
+         if readprocdef.proctypeoption<>potype_propgetter then
+           readprocdef.owner.deletedef(readprocdef);
+         if writeprocdef.proctypeoption<>potype_propsetter then
+           writeprocdef.owner.deletedef(writeprocdef);
 
          result:=p;
       end;

compiler/pexpr.pas

@@ -1053,8 +1053,6 @@ implementation
          callflags  : tcallnodeflags;
          propaccesslist : tpropaccesslist;
          sym: tsym;
-         statements : tstatementnode;
-         converted_result_data : ttempcreatenode;
       begin
          { property parameters? read them only if the property really }
          { has parameters                                             }
@@ -1121,16 +1119,6 @@ implementation
                       end;
                   end;
                 end
-              else
-              if (ppo_dispid_write in propsym.propoptions) then
-                begin
-                  consume(_ASSIGNMENT);
-                  p2:=comp_expr(true,false);
-                  { concat value parameter too }
-                  p2:=ccallparanode.create(p2,paras);
-                  paras:=nil;
-                  p1:=translate_disp_call(p1,p2,dct_propput,'',propsym.dispid,voidtype);
-                end
               else
                 begin
                    p1:=cerrornode.create;
@@ -1168,20 +1156,6 @@ implementation
                        end;
                   end;
                 end
-              else
-              if (ppo_dispid_read in propsym.propoptions) then
-                begin
-                  p2:=internalstatements(statements);
-                  converted_result_data:=ctempcreatenode.create(propsym.propdef,sizeof(propsym.propdef),tt_persistent,true);
-                  addstatement(statements,converted_result_data);
-                  addstatement(statements,cassignmentnode.create(ctemprefnode.create(converted_result_data),
-                    ctypeconvnode.create_internal(translate_disp_call(p1,paras,dct_propget,'',propsym.dispid,propsym.propdef),
-                    propsym.propdef)));
-                  addstatement(statements,ctempdeletenode.create_normal_temp(converted_result_data));
-                  addstatement(statements,ctemprefnode.create(converted_result_data));
-                  p1:=p2;
-                  paras:=nil;
-                end
               else
                 begin
                    { error, no function to read property }
@@ -1932,7 +1906,8 @@ implementation
 
                _LECKKLAMMER:
                   begin
-                    if is_class_or_interface_or_object(p1.resultdef) then
+                    if is_class_or_interface_or_object(p1.resultdef) or
+                      is_dispinterface(p1.resultdef) then
                       begin
                         { default property }
                         protsym:=search_default_property(tobjectdef(p1.resultdef));

compiler/ppu.pas

@@ -43,7 +43,7 @@ type
 {$endif Test_Double_checksum}
 
 const
-  CurrentPPUVersion = 126;
+  CurrentPPUVersion = 127;
 
 { buffer sizes }
   maxentrysize = 1024;

compiler/symconst.pas

@@ -239,7 +239,9 @@ type
     potype_procedure,
     potype_function,
     potype_class_constructor, { class constructor }
-    potype_class_destructor   { class destructor  }
+    potype_class_destructor,  { class destructor  }
+    potype_propgetter,        { Dispinterface property accessors }
+    potype_propsetter
   );
   tproctypeoptions=set of tproctypeoption;
 
@@ -388,8 +390,8 @@ type
     ppo_hasparameters,
     ppo_implements,
     ppo_enumerator_current,
-    ppo_dispid_read,
-    ppo_dispid_write
+    ppo_dispid_read,              { no longer used }
+    ppo_dispid_write              { no longer used }
   );
   tpropertyoptions=set of tpropertyoption;
 

tests/test/tdispinterface2.pp

@@ -22,12 +22,14 @@ type
     procedure DispArg1(Arg: IUnknown);
     procedure DispArg2(Arg: IDispatch);
     function DispArg3(var Arg: wordbool): widestring;
+    property DispProp[index: OleVariant]: Integer;
   end;
 
 var
   cur_dispid: longint;
   cur_argtype: byte;
   cur_restype: byte;
+  cur_calltype: byte;
 
 {$HINTS OFF}
   procedure DoDispCallByID(res: Pointer; const disp: IDispatch; desc: PDispDesc;
@@ -48,6 +50,25 @@ var
       halt($FF);
   end;
 
+  procedure DoDispCallByIDProp(res: Pointer; const disp: IDispatch; desc: PDispDesc;
+    params: Pointer);
+  begin
+    if desc^.calldesc.calltype <> cur_calltype then
+      halt(5);
+    // put: arg #0 is value, arg #1 is index (in Delphi: vice-versa)
+    // get: arg #0 is index
+    if desc^.calldesc.argtypes[ord(cur_calltype=4)] <> cur_argtype then
+      halt(6);  
+    if cur_calltype=4 then
+    begin
+      if desc^.calldesc.argcount <> 2 then
+        halt(7);
+      if desc^.calldesc.argtypes[0] <> cur_restype then
+        halt(8);
+      if desc^.restype <> 0 then
+        halt(9);
+    end;
+  end;
 
 {$HINTS ON}
 
@@ -56,6 +77,7 @@ var
   B: wordbool;
 begin
   // check dispid values
+  writeln('Testing dispid values...');
   DispCallByIDProc := @DoDispCallByID;
   cur_dispid := 300;
   II.Disp300;
@@ -66,6 +88,7 @@ begin
   cur_dispid := 402;
   II.Disp402 := True;
   // check arguments
+  writeln('Testing arguments...');
   DispCallByIDProc := @DoDispCallByIDArg;
   cur_restype := varempty;
   cur_argtype := varunknown;
@@ -76,4 +99,17 @@ begin
   cur_argtype := varboolean or $80;
   B := False;
   II.DispArg3(B);
+
+  writeln('Testing properties...');
+  DispCallByIDProc := @DoDispCallByIDProp;
+  cur_calltype := 2;  // propertyget
+  cur_argtype := varvariant;
+  cur_restype := varinteger;
+  II.DispProp[1];
+  II.DispProp['abc'];
+
+  cur_calltype := 4; // propertyput
+  II.DispProp[1] := 11;
+  II.DispProp['abc'] := 12;
+
 end.