diff --git a/.gitattributes b/.gitattributes index b132c9c30f..2425505e08 100644 --- a/.gitattributes +++ b/.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 diff --git a/compiler/defcmp.pas b/compiler/defcmp.pas index 3701b8ebd0..726d3f2e5f 100644 --- a/compiler/defcmp.pas +++ b/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), diff --git a/compiler/globtype.pas b/compiler/globtype.pas index 399f970d7a..75f2d0437c 100644 --- a/compiler/globtype.pas +++ b/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 ); diff --git a/compiler/pdecvar.pas b/compiler/pdecvar.pas index 51b53d102f..b1670edece 100644 --- a/compiler/pdecvar.pas +++ b/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; diff --git a/compiler/scandir.pas b/compiler/scandir.pas index d7f1ab7b9b..acdff526e9 100644 --- a/compiler/scandir.pas +++ b/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); diff --git a/tests/test/tvarpropsetter1.pp b/tests/test/tvarpropsetter1.pp new file mode 100644 index 0000000000..c445f40b47 --- /dev/null +++ b/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. \ No newline at end of file diff --git a/tests/test/tvarpropsetter2.pp b/tests/test/tvarpropsetter2.pp new file mode 100644 index 0000000000..7f62e77dbb --- /dev/null +++ b/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. \ No newline at end of file