compiler: implement dispinterface properties + modified test

git-svn-id: trunk@14747 -

compiler/pdecvar.pas

@@ -241,6 +241,45 @@ implementation
                (ppo_hasparameters in p.propoptions);
           end;
 
+          procedure parse_dispinterface(p : tpropertysym);
+            var
+              {procsym: tprocsym;
+              procdef: tprocdef;
+              valuepara: tparavarsym;}
+              hasread, haswrite: boolean;
+              pt: tnode;
+            begin
+              p.propaccesslist[palt_read].clear;
+              p.propaccesslist[palt_write].clear;
+
+              hasread:=true;
+              haswrite:=true;
+
+              if try_to_consume(_READONLY) then
+                haswrite:=false
+              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);
+                  if is_constintnode(pt) then
+                    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
+                  else
+                    Message(parser_e_dispid_must_be_ord_const);
+                  pt.free;
+                end;
+            end;
+
       var
          sym : tsym;
          srsymtable: tsymtable;
@@ -524,23 +563,7 @@ implementation
                end;
            end
          else
-           begin
-             if try_to_consume(_READONLY) then
-               begin
-               end
-             else if try_to_consume(_WRITEONLY) then
-               begin
-               end;
-             if try_to_consume(_DISPID) then
-               begin
-                 pt:=comp_expr(true);
-                 if is_constintnode(pt) then
-                   // tprocdef(pd).extnumber:=tordconstnode(pt).value
-                 else
-                   Message(parser_e_dispid_must_be_ord_const);
-                 pt.free;
-               end;
-           end;
+           parse_dispinterface(p);
 
          if assigned(aclass) and not(is_dispinterface(aclass)) and not is_classproperty then
            begin

compiler/pexpr.pas

@@ -1031,6 +1031,8 @@ implementation
          static_name : shortstring;
          sym: tsym;
          srsymtable : tsymtable;
+         statements : tstatementnode;
+         converted_result_data : ttempcreatenode;
       begin
          { property parameters? read them only if the property really }
          { has parameters                                             }
@@ -1108,6 +1110,16 @@ implementation
                       end;
                   end;
                 end
+              else
+              if (ppo_dispid_write in propsym.propoptions) then
+                begin
+                  consume(_ASSIGNMENT);
+                  p2:=comp_expr(true);
+                  { concat value parameter too }
+                  p2:=ccallparanode.create(p2,nil);
+                  { passing p3 here is only for information purposes }
+                  p1:=translate_disp_call(p1,p2,p2,'',propsym.dispid,false);
+                end
               else
                 begin
                    p1:=cerrornode.create;
@@ -1156,6 +1168,19 @@ 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,nil,nil,'',propsym.dispid,true),
+                    propsym.propdef)));
+                  addstatement(statements,ctempdeletenode.create_normal_temp(converted_result_data));
+                  addstatement(statements,ctemprefnode.create(converted_result_data));
+                  p1:=p2;
+                end
               else
                 begin
                    { error, no function to read property }

compiler/ppu.pas

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

compiler/symconst.pas

@@ -366,7 +366,9 @@ type
     ppo_stored,
     ppo_hasparameters,
     ppo_implements,
-    ppo_enumerator_current
+    ppo_enumerator_current,
+    ppo_dispid_read,
+    ppo_dispid_write
   );
   tpropertyoptions=set of tpropertyoption;
 

compiler/symsym.pas

@@ -233,8 +233,9 @@ interface
           indexdef      : tdef;
           indexdefderef : tderef;
           index,
-          default        : longint;
-          propaccesslist : array[tpropaccesslisttypes] of tpropaccesslist;
+          default       : longint;
+          dispid        : longint;
+          propaccesslist: array[tpropaccesslisttypes] of tpropaccesslist;
           constructor create(const n : string);
           destructor  destroy;override;
           constructor ppuload(ppufile:tcompilerppufile);

tests/webtbs/tw15530.pp

@@ -2,21 +2,30 @@
 
 program tw15530;
 
-{$mode objfpc}
+{$ifdef fpc}
+  {$mode objfpc}
+{$endif}
 
 uses
-  ComObj;
+  SysUtils, ActiveX, ComObj;
 
 type
   IIE = dispinterface
     ['{0002DF05-0000-0000-C000-000000000046}']
+    procedure Quit; dispid 300;
     property Visible: wordbool dispid 402;
   end;
-
 var
   II: IIE;
 begin
+  OleInitialize(nil);
+
   II := CreateOleObject('InternetExplorer.Application') as IIE;
-  if II <> nil then
-    ;
+
+  if not II.Visible then // test dispid property getter
+    II.Visible := True;  // test dispid property setter
+
+  II.Quit; // test dipid method call
+
+  OleUninitialize;
 end.