compiler: implement {$VARPROPSETTER ON/OFF} support which is required for COM (D7 compatibility):

- add an option to skip varspez during parameters comparison
  - skip varspez comparison when searching a property reader candidate if $VARPROPSETTER is ON

git-svn-id: trunk@15020 -

.gitattributes

@@ -9330,6 +9330,8 @@ tests/test/tunit3.pp svneol=native#text/plain
 tests/test/tunroll1.pp svneol=native#text/plain
 tests/test/tutf81.pp svneol=native#text/plain
 tests/test/tutf82.pp svneol=native#text/plain
+tests/test/tvarpropsetter1.pp svneol=native#text/plain
+tests/test/tvarpropsetter2.pp svneol=native#text/plain
 tests/test/tvarset1.pp svneol=native#text/plain
 tests/test/tweaklib1.pp svneol=native#text/plain
 tests/test/tweaklib2.pp svneol=native#text/plain

compiler/defcmp.pas

@@ -34,7 +34,17 @@ interface
      type
        { if acp is cp_all the var const or nothing are considered equal }
        tcompare_paras_type = ( cp_none, cp_value_equal_const, cp_all,cp_procvar);
-       tcompare_paras_option = (cpo_allowdefaults,cpo_ignorehidden,cpo_allowconvert,cpo_comparedefaultvalue,cpo_openequalisexact,cpo_ignoreuniv,cpo_warn_incompatible_univ);
+       tcompare_paras_option = (
+          cpo_allowdefaults,
+          cpo_ignorehidden,           // ignore hidden parameters
+          cpo_allowconvert,
+          cpo_comparedefaultvalue,
+          cpo_openequalisexact,
+          cpo_ignoreuniv,
+          cpo_warn_incompatible_univ,
+          cpo_ignorevarspez           // ignore parameter access type
+       );
+
        tcompare_paras_options = set of tcompare_paras_option;
 
        tcompare_defs_option = (cdo_internal,cdo_explicit,cdo_check_operator,cdo_allow_variant,cdo_parameter,cdo_warn_incompatible_univ);
@@ -1619,7 +1629,8 @@ implementation
                 if not(vo_is_self in currpara1.varoptions) and
                    not(vo_is_self in currpara2.varoptions) then
                  begin
-                   if (currpara1.varspez<>currpara2.varspez) then
+                   if not(cpo_ignorevarspez in cpoptions) and
+                      (currpara1.varspez<>currpara2.varspez) then
                     exit;
                    eq:=compare_defs_ext(currpara1.vardef,currpara2.vardef,nothingn,
                                         convtype,hpd,cdoptions);
@@ -1635,6 +1646,7 @@ implementation
                          in any case since the call statement does not contain
                          any information about that }
                        if (
+                           not(cpo_ignorevarspez in cpoptions) and
                            (currpara1.varspez<>currpara2.varspez) and
                            ((currpara1.varspez in [vs_var,vs_out]) or
                             (currpara2.varspez in [vs_var,vs_out]))
@@ -1647,7 +1659,8 @@ implementation
                     begin
                        { used to resolve forward definitions -> headers must
                          match exactly, including the "univ" specifier }
-                       if (currpara1.varspez<>currpara2.varspez) or
+                       if (not(cpo_ignorevarspez in cpoptions) and
+                           (currpara1.varspez<>currpara2.varspez)) or
                           (currpara1.univpara<>currpara2.univpara) then
                          exit;
                        eq:=compare_defs_ext(currpara1.vardef,currpara2.vardef,nothingn,
@@ -1655,7 +1668,8 @@ implementation
                     end;
                   cp_procvar :
                     begin
-                       if (currpara1.varspez<>currpara2.varspez) then
+                       if not(cpo_ignorevarspez in cpoptions) and
+                          (currpara1.varspez<>currpara2.varspez) then
                          exit;
                        { "univ" state doesn't matter here: from univ to non-univ
                           matches if the types are compatible (i.e., as usual),

compiler/globtype.pas

@@ -110,6 +110,7 @@ interface
          cs_mmx,cs_mmx_saturation,
          { parser }
          cs_typed_addresses,cs_strict_var_strings,cs_ansistrings,cs_bitpacking,
+         cs_varpropsetter,
          { macpas specific}
          cs_external_var, cs_externally_visible
        );

compiler/pdecvar.pas

@@ -536,7 +536,10 @@ implementation
                           { Insert hidden parameters }
                           handle_calling_convention(writeprocdef);
                           { search procdefs matching writeprocdef }
-                          p.propaccesslist[palt_write].procdef:=Tprocsym(sym).Find_procdef_bypara(writeprocdef.paras,writeprocdef.returndef,[cpo_allowdefaults]);
+                          if cs_varpropsetter in current_settings.localswitches then
+                            p.propaccesslist[palt_write].procdef:=Tprocsym(sym).Find_procdef_bypara(writeprocdef.paras,writeprocdef.returndef,[cpo_allowdefaults,cpo_ignorevarspez])
+                          else
+                            p.propaccesslist[palt_write].procdef:=Tprocsym(sym).Find_procdef_bypara(writeprocdef.paras,writeprocdef.returndef,[cpo_allowdefaults]);
                           if not assigned(p.propaccesslist[palt_write].procdef) then
                             Message(parser_e_ill_property_access_sym);
                         end;

compiler/scandir.pas

@@ -1087,6 +1087,11 @@ unit scandir;
             end;
       end;
 
+    procedure dir_varpropsetter;
+      begin
+        do_localswitch(cs_varpropsetter);
+      end;
+
     procedure dir_varstringchecks;
       begin
         do_delphiswitch('V');
@@ -1454,6 +1459,7 @@ unit scandir;
         AddDirective('TYPEDADDRESS',directive_all, @dir_typedaddress);
         AddDirective('TYPEINFO',directive_all, @dir_typeinfo);
         AddDirective('UNITPATH',directive_all, @dir_unitpath);
+        AddDirective('VARPROPSETTER',directive_all, @dir_varpropsetter);
         AddDirective('VARSTRINGCHECKS',directive_all, @dir_varstringchecks);
         AddDirective('VERSION',directive_all, @dir_version);
         AddDirective('WAIT',directive_all, @dir_wait);

tests/test/tvarpropsetter1.pp

@@ -0,0 +1,44 @@
+program tvarpropsetter1;
+
+{$ifdef fpc}
+{$mode delphi}
+{$endif}
+
+{$VARPROPSETTER ON}
+
+type
+  TSomeClass = class
+  private
+    FTest: Integer;
+    function GetTest: Integer;
+    procedure SetTest(var AValue: Integer);
+  public
+    property Test: Integer read GetTest write SetTest;
+  end;
+
+{ TSomeClass }
+
+function TSomeClass.GetTest: Integer;
+begin
+  Result := FTest;
+end;
+
+procedure TSomeClass.SetTest(var AValue: Integer);
+begin
+  FTest := AValue;
+  AValue := 10;
+end;
+
+var
+  Cl: TSomeClass;
+  D: Integer;
+begin
+  Cl := TSomeClass.Create;
+  D := 5;
+  Cl.Test := D;
+  if Cl.Test <> 5 then
+    halt(1);
+  if D <> 10 then
+    halt(2);
+  Cl.Free;
+end.

tests/test/tvarpropsetter2.pp

@@ -0,0 +1,39 @@
+{%fail}
+program tvarpropsetter2;
+
+{$ifdef fpc}
+{$mode delphi}
+{$endif}
+
+{$VARPROPSETTER ON}
+
+type
+  TSomeClass = class
+  private
+    FTest: Integer;
+    function GetTest: Integer;
+    procedure SetTest(var AValue: Integer);
+  public
+    property Test: Integer read GetTest write SetTest;
+  end;
+
+{ TSomeClass }
+
+function TSomeClass.GetTest: Integer;
+begin
+  Result := FTest;
+end;
+
+procedure TSomeClass.SetTest(var AValue: Integer);
+begin
+  FTest := AValue;
+  AValue := 10;
+end;
+
+var
+  Cl: TSomeClass;
+begin
+  Cl := TSomeClass.Create;
+  Cl.Test := 5; // fails because requires a variable
+  Cl.Free;
+end.