* factored out associating properties with their getters/setters/fiels

   o moved JVM-specific code from pdecvar (and pjvm) to jvm/symcpu

git-svn-id: trunk@27938 -

compiler/jvm/pjvm.pas

@@ -48,13 +48,6 @@ interface
 
     function jvm_wrap_method_with_vis(pd: tprocdef; vis: tvisibility): tprocdef;
 
-    { when a private/protected field is exposed via a property with a higher
-      visibility, then we have to create a getter and/or setter with that same
-      higher visibility to make sure that using the property does not result
-      in JVM verification errors }
-    procedure jvm_create_getter_for_property(p: tpropertysym; orgaccesspd: tprocdef);
-    procedure jvm_create_setter_for_property(p: tpropertysym; orgaccesspd: tprocdef);
-
 
 implementation
 
@@ -853,287 +846,4 @@ implementation
       end;
 
 
-    procedure jvm_create_getter_or_setter_for_property(p: tpropertysym; orgaccesspd: tprocdef; getter: boolean);
-      var
-        obj: tabstractrecorddef;
-        ps: tprocsym;
-        pvs: tparavarsym;
-        sym: tsym;
-        pd, parentpd, accessorparapd: tprocdef;
-        tmpaccesslist: tpropaccesslist;
-        callthroughpropname,
-        name: string;
-        callthroughprop: tpropertysym;
-        accesstyp: tpropaccesslisttypes;
-        sktype: tsynthetickind;
-        procoptions: tprocoptions;
-        paranr: word;
-        explicitwrapper: boolean;
-      begin
-        obj:=current_structdef;
-        { if someone gets the idea to add a property to an external class
-          definition, don't try to wrap it since we cannot add methods to
-          external classes }
-        if oo_is_external in obj.objectoptions then
-          exit;
-        symtablestack.push(obj.symtable);
-
-        try
-          if getter then
-            accesstyp:=palt_read
-          else
-            accesstyp:=palt_write;
-
-          { we can't use str_parse_method_dec here because the type of the field
-            may not be visible at the Pascal level }
-
-          explicitwrapper:=
-            { private methods are not visibile outside the current class, so
-              no use in making life harder for us by introducing potential
-              (future or current) naming conflicts }
-            (p.visibility<>vis_private) and
-            (getter and
-             (prop_auto_getter_prefix<>'')) or
-            (not getter and
-             (prop_auto_setter_prefix<>''));
-          sym:=nil;
-          procoptions:=[];
-          if explicitwrapper then
-            begin
-              if getter then
-                name:=prop_auto_getter_prefix+p.realname
-              else
-                name:=prop_auto_setter_prefix+p.realname;
-              sym:=search_struct_member_no_helper(obj,upper(name));
-              if getter then
-                sktype:=tsk_field_getter
-              else
-                sktype:=tsk_field_setter;
-              if assigned(sym) then
-                begin
-                  if ((sym.typ<>procsym) or
-                      (tprocsym(sym).procdeflist.count<>1) or
-                      (tprocdef(tprocsym(sym).procdeflist[0]).synthetickind<>sktype)) and
-                     (not assigned(orgaccesspd) or
-                      (sym<>orgaccesspd.procsym)) then
-                    begin
-                      MessagePos2(p.fileinfo,parser_e_cannot_generate_property_getter_setter,name,FullTypeName(tdef(sym.owner.defowner),nil)+'.'+name);
-                      exit;
-                    end
-                  else
-                    begin
-                      if name<>sym.realname then
-                        MessagePos2(p.fileinfo,parser_w_case_difference_auto_property_getter_setter_prefix,sym.realname,name);
-                      { is the specified getter/setter defined in the current
-                        struct and was it originally specified as the getter/
-                        setter for this property? If so, simply adjust its
-                        visibility if necessary.
-                      }
-                      if assigned(orgaccesspd) then
-                        parentpd:=orgaccesspd
-                      else
-                        parentpd:=tprocdef(tprocsym(sym).procdeflist[0]);
-                      if parentpd.owner.defowner=p.owner.defowner then
-                        begin
-                          if parentpd.visibility<p.visibility then
-                            begin
-                              parentpd.visibility:=p.visibility;
-                              include(parentpd.procoptions,po_auto_raised_visibility);
-                            end;
-                          { we are done, no need to create a wrapper }
-                          exit
-                        end
-                      { a parent already included this getter/setter -> try to
-                        override it }
-                      else if parentpd.visibility<>vis_private then
-                        begin
-                          if po_virtualmethod in parentpd.procoptions then
-                            begin
-                              procoptions:=procoptions+[po_virtualmethod,po_overridingmethod];
-                              Message2(parser_w_overriding_property_getter_setter,name,FullTypeName(tdef(parentpd.owner.defowner),nil));
-                            end;
-                          { otherwise we can't do anything, and
-                            proc_add_definition will give an error }
-                        end;
-                      { add method with the correct visibility }
-                      pd:=tprocdef(parentpd.getcopy);
-                      { get rid of the import name for inherited virtual class methods,
-                        it has to be regenerated rather than amended }
-                      if [po_classmethod,po_virtualmethod]<=pd.procoptions then
-                        begin
-                          stringdispose(pd.import_name);
-                          exclude(pd.procoptions,po_has_importname);
-                        end;
-                      pd.visibility:=p.visibility;
-                      pd.procoptions:=pd.procoptions+procoptions;
-                      { ignore this artificially added procdef when looking for overloads }
-                      include(pd.procoptions,po_ignore_for_overload_resolution);
-                      finish_copied_procdef(pd,parentpd.procsym.realname,obj.symtable,obj);
-                      exclude(pd.procoptions,po_external);
-                      pd.synthetickind:=tsk_anon_inherited;
-                      exit;
-                    end;
-                end;
-              { make the artificial getter/setter virtual so we can override it in
-                children if necessary }
-              if not(sp_static in p.symoptions) and
-                 (obj.typ=objectdef) then
-                include(procoptions,po_virtualmethod);
-              { prevent problems in Delphi mode }
-              include(procoptions,po_overload);
-            end
-          else
-            begin
-              { construct procsym name (unique for this access; reusing the same
-                helper for multiple accesses to the same field is hard because the
-                propacesslist can contain subscript nodes etc) }
-              name:=visibilityName[p.visibility];
-              replace(name,' ','_');
-              if getter then
-                name:=name+'$getter'
-              else
-                name:=name+'$setter';
-            end;
-
-          { create procdef }
-          if not assigned(orgaccesspd) then
-            begin
-              pd:=cprocdef.create(normal_function_level);
-              if df_generic in obj.defoptions then
-                include(pd.defoptions,df_generic);
-              { method of this objectdef }
-              pd.struct:=obj;
-              { can only construct the artificial name now, because it requires
-                pd.defid }
-              if not explicitwrapper then
-                name:='$'+obj.symtable.realname^+'$'+p.realname+'$'+name+'$'+tostr(pd.defid);
-            end
-          else
-            begin
-              { getter/setter could have parameters in case of indexed access
-                -> copy original procdef }
-              pd:=tprocdef(orgaccesspd.getcopy);
-              exclude(pd.procoptions,po_abstractmethod);
-              { can only construct the artificial name now, because it requires
-                pd.defid }
-              if not explicitwrapper then
-                name:='$'+obj.symtable.realname^+'$'+p.realname+'$'+name+'$'+tostr(pd.defid);
-              finish_copied_procdef(pd,name,obj.symtable,obj);
-              sym:=pd.procsym;
-            end;
-          { add previously collected procoptions }
-          pd.procoptions:=pd.procoptions+procoptions;
-          { visibility }
-          pd.visibility:=p.visibility;
-
-          { new procsym? }
-          if not assigned(sym) or
-             (sym.owner<>p.owner)  then
-            begin
-              ps:=cprocsym.create(name);
-              obj.symtable.insert(ps);
-            end
-          else
-            ps:=tprocsym(sym);
-          { associate procsym with procdef}
-          pd.procsym:=ps;
-
-
-
-          { function/procedure }
-          accessorparapd:=nil;
-          if getter then
-            begin
-              pd.proctypeoption:=potype_function;
-              pd.synthetickind:=tsk_field_getter;
-              { result type }
-              pd.returndef:=p.propdef;
-              if (ppo_hasparameters in p.propoptions) and
-                 not assigned(orgaccesspd) then
-                accessorparapd:=pd;
-            end
-          else
-            begin
-              pd.proctypeoption:=potype_procedure;
-              pd.synthetickind:=tsk_field_setter;
-              pd.returndef:=voidtype;
-              if not assigned(orgaccesspd) then
-                begin
-                  { parameter with value to set }
-                  pvs:=cparavarsym.create('__fpc_newval__',10,vs_const,p.propdef,[]);
-                  pd.parast.insert(pvs);
-                end;
-              if (ppo_hasparameters in p.propoptions) and
-                 not assigned(orgaccesspd) then
-                accessorparapd:=pd;
-            end;
-
-          { create a property for the old symaccesslist with a new name, so that
-            we can reuse it in the implementation (rather than having to
-            translate the symaccesslist back to Pascal code) }
-          callthroughpropname:='__fpc__'+p.realname;
-          if getter then
-            callthroughpropname:=callthroughpropname+'__getter_wrapper'
-          else
-            callthroughpropname:=callthroughpropname+'__setter_wrapper';
-          callthroughprop:=cpropertysym.create(callthroughpropname);
-          callthroughprop.visibility:=p.visibility;
-
-          if getter then
-            p.makeduplicate(callthroughprop,accessorparapd,nil,paranr)
-          else
-            p.makeduplicate(callthroughprop,nil,accessorparapd,paranr);
-
-          callthroughprop.default:=longint($80000000);
-          callthroughprop.default:=0;
-          callthroughprop.propoptions:=callthroughprop.propoptions-[ppo_stored,ppo_enumerator_current,ppo_overrides,ppo_defaultproperty];
-          if sp_static in p.symoptions then
-            include(callthroughprop.symoptions, sp_static);
-          { copy original property target to callthrough property (and replace
-            original one with the new empty list; will be filled in later) }
-          tmpaccesslist:=callthroughprop.propaccesslist[accesstyp];
-          callthroughprop.propaccesslist[accesstyp]:=p.propaccesslist[accesstyp];
-          p.propaccesslist[accesstyp]:=tmpaccesslist;
-          p.owner.insert(callthroughprop);
-
-          pd.skpara:=callthroughprop;
-          { needs to be exported }
-          include(pd.procoptions,po_global);
-          { class property -> static class method }
-          if sp_static in p.symoptions then
-            pd.procoptions:=pd.procoptions+[po_classmethod,po_staticmethod];
-
-          { in case we made a copy of the original accessor, this has all been
-            done already }
-          if not assigned(orgaccesspd) then
-            begin
-              { calling convention, self, ... }
-              if obj.typ=recorddef then
-                handle_calling_convention(pd,[hcc_check])
-              else
-                handle_calling_convention(pd,hcc_all);
-              { register forward declaration with procsym }
-              proc_add_definition(pd);
-            end;
-
-          { make the property call this new function }
-          p.propaccesslist[accesstyp].addsym(sl_call,ps);
-          p.propaccesslist[accesstyp].procdef:=pd;
-        finally
-          symtablestack.pop(obj.symtable);
-        end;
-      end;
-
-
-    procedure jvm_create_getter_for_property(p: tpropertysym; orgaccesspd: tprocdef);
-      begin
-        jvm_create_getter_or_setter_for_property(p,orgaccesspd,true);
-      end;
-
-
-    procedure jvm_create_setter_for_property(p: tpropertysym; orgaccesspd: tprocdef);
-      begin
-        jvm_create_getter_or_setter_for_property(p,orgaccesspd,false);
-      end;
-
 end.

compiler/jvm/symcpu.pas

@@ -182,6 +182,13 @@ type
   tcpuabsolutevarsymclass = class of tcpuabsolutevarsym;
 
   tcpupropertysym = class(tpropertysym)
+   protected
+    { when a private/protected field is exposed via a property with a higher
+      visibility, then we have to create a getter and/or setter with that same
+      higher visibility to make sure that using the property does not result
+      in JVM verification errors }
+    procedure create_getter_or_setter_for_property(orgaccesspd: tprocdef; getter: boolean);
+    procedure finalize_getter_or_setter_for_sym(getset: tpropaccesslisttypes; sym: tsym; fielddef: tdef; accessordef: tprocdef); override;
   end;
   tcpupropertysymclass = class of tcpupropertysym;
 
@@ -205,11 +212,334 @@ const
 implementation
 
   uses
-    verbose,cutils,cclasses,
-    symconst,symbase,jvmdef,
+    verbose,cutils,cclasses,globals,
+    symconst,symbase,symtable,symcreat,jvmdef,
+    pdecsub,pjvm,
     paramgr;
 
 
+  {****************************************************************************
+                               tcpuproptertysym
+  ****************************************************************************}
+
+  procedure tcpupropertysym.create_getter_or_setter_for_property(orgaccesspd: tprocdef; getter: boolean);
+    var
+      obj: tabstractrecorddef;
+      ps: tprocsym;
+      pvs: tparavarsym;
+      sym: tsym;
+      pd, parentpd, accessorparapd: tprocdef;
+      tmpaccesslist: tpropaccesslist;
+      callthroughpropname,
+      accessorname: string;
+      callthroughprop: tpropertysym;
+      accesstyp: tpropaccesslisttypes;
+      sktype: tsynthetickind;
+      procoptions: tprocoptions;
+      paranr: word;
+      explicitwrapper: boolean;
+    begin
+      obj:=current_structdef;
+      { if someone gets the idea to add a property to an external class
+        definition, don't try to wrap it since we cannot add methods to
+        external classes }
+      if oo_is_external in obj.objectoptions then
+        exit;
+      symtablestack.push(obj.symtable);
+
+      try
+        if getter then
+          accesstyp:=palt_read
+        else
+          accesstyp:=palt_write;
+
+        { we can't use str_parse_method_dec here because the type of the field
+          may not be visible at the Pascal level }
+
+        explicitwrapper:=
+          { private methods are not visibile outside the current class, so
+            no use in making life harder for us by introducing potential
+            (future or current) naming conflicts }
+          (visibility<>vis_private) and
+          (getter and
+           (prop_auto_getter_prefix<>'')) or
+          (not getter and
+           (prop_auto_setter_prefix<>''));
+        sym:=nil;
+        procoptions:=[];
+        if explicitwrapper then
+          begin
+            if getter then
+              accessorname:=prop_auto_getter_prefix+realname
+            else
+              accessorname:=prop_auto_setter_prefix+realname;
+            sym:=search_struct_member_no_helper(obj,upper(accessorname));
+            if getter then
+              sktype:=tsk_field_getter
+            else
+              sktype:=tsk_field_setter;
+            if assigned(sym) then
+              begin
+                if ((sym.typ<>procsym) or
+                    (tprocsym(sym).procdeflist.count<>1) or
+                    (tprocdef(tprocsym(sym).procdeflist[0]).synthetickind<>sktype)) and
+                   (not assigned(orgaccesspd) or
+                    (sym<>orgaccesspd.procsym)) then
+                  begin
+                    MessagePos2(fileinfo,parser_e_cannot_generate_property_getter_setter,accessorname,FullTypeName(tdef(sym.owner.defowner),nil)+'.'+accessorname);
+                    exit;
+                  end
+                else
+                  begin
+                    if accessorname<>sym.realname then
+                      MessagePos2(fileinfo,parser_w_case_difference_auto_property_getter_setter_prefix,sym.realname,accessorname);
+                    { is the specified getter/setter defined in the current
+                      struct and was it originally specified as the getter/
+                      setter for this property? If so, simply adjust its
+                      visibility if necessary.
+                    }
+                    if assigned(orgaccesspd) then
+                      parentpd:=orgaccesspd
+                    else
+                      parentpd:=tprocdef(tprocsym(sym).procdeflist[0]);
+                    if parentpd.owner.defowner=owner.defowner then
+                      begin
+                        if parentpd.visibility<visibility then
+                          begin
+                            parentpd.visibility:=visibility;
+                            include(parentpd.procoptions,po_auto_raised_visibility);
+                          end;
+                        { we are done, no need to create a wrapper }
+                        exit
+                      end
+                    { a parent already included this getter/setter -> try to
+                      override it }
+                    else if parentpd.visibility<>vis_private then
+                      begin
+                        if po_virtualmethod in parentpd.procoptions then
+                          begin
+                            procoptions:=procoptions+[po_virtualmethod,po_overridingmethod];
+                            Message2(parser_w_overriding_property_getter_setter,accessorname,FullTypeName(tdef(parentpd.owner.defowner),nil));
+                          end;
+                        { otherwise we can't do anything, and
+                          proc_add_definition will give an error }
+                      end;
+                    { add method with the correct visibility }
+                    pd:=tprocdef(parentpd.getcopy);
+                    { get rid of the import accessorname for inherited virtual class methods,
+                      it has to be regenerated rather than amended }
+                    if [po_classmethod,po_virtualmethod]<=pd.procoptions then
+                      begin
+                        stringdispose(pd.import_name);
+                        exclude(pd.procoptions,po_has_importname);
+                      end;
+                    pd.visibility:=visibility;
+                    pd.procoptions:=pd.procoptions+procoptions;
+                    { ignore this artificially added procdef when looking for overloads }
+                    include(pd.procoptions,po_ignore_for_overload_resolution);
+                    finish_copied_procdef(pd,parentpd.procsym.realname,obj.symtable,obj);
+                    exclude(pd.procoptions,po_external);
+                    pd.synthetickind:=tsk_anon_inherited;
+                    exit;
+                  end;
+              end;
+            { make the artificial getter/setter virtual so we can override it in
+              children if necessary }
+            if not(sp_static in symoptions) and
+               (obj.typ=objectdef) then
+              include(procoptions,po_virtualmethod);
+            { prevent problems in Delphi mode }
+            include(procoptions,po_overload);
+          end
+        else
+          begin
+            { construct procsym accessorname (unique for this access; reusing the same
+              helper for multiple accesses to the same field is hard because the
+              propacesslist can contain subscript nodes etc) }
+            accessorname:=visibilityName[visibility];
+            replace(accessorname,' ','_');
+            if getter then
+              accessorname:=accessorname+'$getter'
+            else
+              accessorname:=accessorname+'$setter';
+          end;
+
+        { create procdef }
+        if not assigned(orgaccesspd) then
+          begin
+            pd:=cprocdef.create(normal_function_level);
+            if df_generic in obj.defoptions then
+              include(pd.defoptions,df_generic);
+            { method of this objectdef }
+            pd.struct:=obj;
+            { can only construct the artificial accessorname now, because it requires
+              pd.defid }
+            if not explicitwrapper then
+              accessorname:='$'+obj.symtable.realname^+'$'+realname+'$'+accessorname+'$'+tostr(pd.defid);
+          end
+        else
+          begin
+            { getter/setter could have parameters in case of indexed access
+              -> copy original procdef }
+            pd:=tprocdef(orgaccesspd.getcopy);
+            exclude(pd.procoptions,po_abstractmethod);
+            { can only construct the artificial accessorname now, because it requires
+              pd.defid }
+            if not explicitwrapper then
+              accessorname:='$'+obj.symtable.realname^+'$'+realname+'$'+accessorname+'$'+tostr(pd.defid);
+            finish_copied_procdef(pd,accessorname,obj.symtable,obj);
+            sym:=pd.procsym;
+          end;
+        { add previously collected procoptions }
+        pd.procoptions:=pd.procoptions+procoptions;
+        { visibility }
+        pd.visibility:=visibility;
+
+        { new procsym? }
+        if not assigned(sym) or
+           (sym.owner<>owner)  then
+          begin
+            ps:=cprocsym.create(accessorname);
+            obj.symtable.insert(ps);
+          end
+        else
+          ps:=tprocsym(sym);
+        { associate procsym with procdef}
+        pd.procsym:=ps;
+
+
+
+        { function/procedure }
+        accessorparapd:=nil;
+        if getter then
+          begin
+            pd.proctypeoption:=potype_function;
+            pd.synthetickind:=tsk_field_getter;
+            { result type }
+            pd.returndef:=propdef;
+            if (ppo_hasparameters in propoptions) and
+               not assigned(orgaccesspd) then
+              accessorparapd:=pd;
+          end
+        else
+          begin
+            pd.proctypeoption:=potype_procedure;
+            pd.synthetickind:=tsk_field_setter;
+            pd.returndef:=voidtype;
+            if not assigned(orgaccesspd) then
+              begin
+                { parameter with value to set }
+                pvs:=cparavarsym.create('__fpc_newval__',10,vs_const,propdef,[]);
+                pd.parast.insert(pvs);
+              end;
+            if (ppo_hasparameters in propoptions) and
+               not assigned(orgaccesspd) then
+              accessorparapd:=pd;
+          end;
+
+        { create a property for the old symaccesslist with a new accessorname, so that
+          we can reuse it in the implementation (rather than having to
+          translate the symaccesslist back to Pascal code) }
+        callthroughpropname:='__fpc__'+realname;
+        if getter then
+          callthroughpropname:=callthroughpropname+'__getter_wrapper'
+        else
+          callthroughpropname:=callthroughpropname+'__setter_wrapper';
+        callthroughprop:=cpropertysym.create(callthroughpropname);
+        callthroughprop.visibility:=visibility;
+
+        if getter then
+          makeduplicate(callthroughprop,accessorparapd,nil,paranr)
+        else
+          makeduplicate(callthroughprop,nil,accessorparapd,paranr);
+
+        callthroughprop.default:=longint($80000000);
+        callthroughprop.default:=0;
+        callthroughprop.propoptions:=callthroughprop.propoptions-[ppo_stored,ppo_enumerator_current,ppo_overrides,ppo_defaultproperty];
+        if sp_static in symoptions then
+          include(callthroughprop.symoptions, sp_static);
+        { copy original property target to callthrough property (and replace
+          original one with the new empty list; will be filled in later) }
+        tmpaccesslist:=callthroughprop.propaccesslist[accesstyp];
+        callthroughprop.propaccesslist[accesstyp]:=propaccesslist[accesstyp];
+        propaccesslist[accesstyp]:=tmpaccesslist;
+        owner.insert(callthroughprop);
+
+        pd.skpara:=callthroughprop;
+        { needs to be exported }
+        include(pd.procoptions,po_global);
+        { class property -> static class method }
+        if sp_static in symoptions then
+          pd.procoptions:=pd.procoptions+[po_classmethod,po_staticmethod];
+
+        { in case we made a copy of the original accessor, this has all been
+          done already }
+        if not assigned(orgaccesspd) then
+          begin
+            { calling convention, self, ... }
+            if obj.typ=recorddef then
+              handle_calling_convention(pd,[hcc_check])
+            else
+              handle_calling_convention(pd,hcc_all);
+            { register forward declaration with procsym }
+            proc_add_definition(pd);
+          end;
+
+        { make the property call this new function }
+        propaccesslist[accesstyp].addsym(sl_call,ps);
+        propaccesslist[accesstyp].procdef:=pd;
+      finally
+        symtablestack.pop(obj.symtable);
+      end;
+    end;
+
+
+  procedure tcpupropertysym.finalize_getter_or_setter_for_sym(getset: tpropaccesslisttypes; sym: tsym; fielddef: tdef; accessordef: tprocdef);
+    var
+      orgaccesspd: tprocdef;
+      pprefix: pstring;
+      wrongvisibility: boolean;
+    begin
+      inherited;
+      if getset=palt_read then
+        pprefix:=@prop_auto_getter_prefix
+      else
+        pprefix:=@prop_auto_setter_prefix;
+      case sym.typ of
+        procsym:
+          begin
+            orgaccesspd:=tprocdef(propaccesslist[getset].procdef);
+            wrongvisibility:=tprocdef(propaccesslist[getset].procdef).visibility<visibility;
+            if (pprefix^<>'') and
+               (wrongvisibility or
+                (sym.RealName<>pprefix^+RealName)) then
+              create_getter_or_setter_for_property(orgaccesspd,getset=palt_read)
+            { if the visibility of the accessor is lower than
+              the visibility of the property, wrap it so that
+              we can call it from all contexts in which the
+              property is visible }
+            else if wrongvisibility then
+             begin
+               propaccesslist[getset].procdef:=jvm_wrap_method_with_vis(tprocdef(propaccesslist[palt_read].procdef),visibility);
+               propaccesslist[getset].firstsym^.sym:=tprocdef(propaccesslist[getset].procdef).procsym;
+             end;
+          end;
+        fieldvarsym:
+          begin
+            { if the visibility of the field is lower than the
+              visibility of the property, wrap it in a getter
+              so that we can access it from all contexts in
+              which the property is visibile }
+            if (pprefix^<>'') or
+               (tfieldvarsym(sym).visibility<visibility) then
+              create_getter_or_setter_for_property(nil,getset=palt_read);
+          end;
+        else
+          internalerror(2014061101);
+      end;
+    end;
+
+
 {****************************************************************************
                              tcpuenumdef
 ****************************************************************************}

compiler/pdecvar.pas

@@ -520,79 +520,21 @@ implementation
 
          if not(is_dispinterface(astruct)) then
            begin
+             { parse accessors }
              if try_to_consume(_READ) then
                begin
                  p.propaccesslist[palt_read].clear;
                  if parse_symlist(p.propaccesslist[palt_read],def) then
                   begin
                     sym:=p.propaccesslist[palt_read].firstsym^.sym;
-                    case sym.typ of
-                      procsym :
-                        begin
-                          { read is function returning the type of the property }
-                          readprocdef.returndef:=p.propdef;
-                          { Insert hidden parameters }
-                          handle_calling_convention(readprocdef);
-                          { search procdefs matching readprocdef }
-                          { we ignore hidden stuff here because the property access symbol might have
-                            non default calling conventions which might change the hidden stuff;
-                            see tw3216.pp (FK) }
-                          p.propaccesslist[palt_read].procdef:=Tprocsym(sym).Find_procdef_bypara(readprocdef.paras,p.propdef,[cpo_allowdefaults,cpo_ignorehidden]);
-                          if not assigned(p.propaccesslist[palt_read].procdef) or
-                            { because of cpo_ignorehidden we need to compare if it is a static class method and we have a class property }
-                            ((sp_static in p.symoptions) <> tprocdef(p.propaccesslist[palt_read].procdef).no_self_node) then
-                            Message(parser_e_ill_property_access_sym)
-                          else
-                            begin
-{$ifdef jvm}
-                              orgaccesspd:=tprocdef(p.propaccesslist[palt_read].procdef);
-                              wrongvisibility:=tprocdef(p.propaccesslist[palt_read].procdef).visibility<p.visibility;
-                              if (prop_auto_getter_prefix<>'') and
-                                 (wrongvisibility or
-                                   (p.propaccesslist[palt_read].firstsym^.sym.RealName<>prop_auto_getter_prefix+p.RealName)) then
-                                jvm_create_getter_for_property(p,orgaccesspd)
-                              { if the visibility of the getter is lower than
-                                the visibility of the property, wrap it so that
-                                we can call it from all contexts in which the
-                                property is visible }
-                              else if wrongvisibility then
-                               begin
-                                 p.propaccesslist[palt_read].procdef:=jvm_wrap_method_with_vis(tprocdef(p.propaccesslist[palt_read].procdef),p.visibility);
-                                 p.propaccesslist[palt_read].firstsym^.sym:=tprocdef(p.propaccesslist[palt_read].procdef).procsym;
-                               end;
-{$endif jvm}
-                            end;
-                        end;
-                      fieldvarsym :
-                        begin
-                          if not assigned(def) then
-                            internalerror(200310071);
-                          if compare_defs(def,p.propdef,nothingn)>=te_equal then
-                           begin
-                             { property parameters are allowed if this is
-                               an indexed property, because the index is then
-                               the parameter.
-                               Note: In the help of Kylix it is written
-                               that it isn't allowed, but the compiler accepts it (PFV) }
-                             if (ppo_hasparameters in p.propoptions) or
-                                ((sp_static in p.symoptions) <> (sp_static in sym.symoptions)) then
-                               Message(parser_e_ill_property_access_sym);
-{$ifdef jvm}
-                             { if the visibility of the field is lower than the
-                               visibility of the property, wrap it in a getter
-                               so that we can access it from all contexts in
-                               which the property is visibile }
-                             if (prop_auto_getter_prefix<>'') or
-                                (tfieldvarsym(sym).visibility<p.visibility) then
-                               jvm_create_getter_for_property(p,nil);
-{$endif}
-                           end
-                          else
-                           IncompatibleTypes(def,p.propdef);
-                        end;
-                      else
-                        Message(parser_e_ill_property_access_sym);
-                    end;
+                    { getter is a function returning the type of the property }
+                    if sym.typ=procsym then
+                      begin
+                        readprocdef.returndef:=p.propdef;
+                        { Insert hidden parameters }
+                        handle_calling_convention(readprocdef);
+                      end;
+                    p.add_getter_or_setter_for_sym(palt_read,sym,def,readprocdef);
                   end;
                end;
              if try_to_consume(_WRITE) then
@@ -601,81 +543,18 @@ implementation
                  if parse_symlist(p.propaccesslist[palt_write],def) then
                   begin
                     sym:=p.propaccesslist[palt_write].firstsym^.sym;
-                    case sym.typ of
-                      procsym :
-                        begin
-                          { write is a procedure with an extra value parameter
-                            of the of the property }
-                          writeprocdef.returndef:=voidtype;
-                          inc(paranr);
-                          hparavs:=cparavarsym.create('$value',10*paranr,vs_value,p.propdef,[]);
-                          writeprocdef.parast.insert(hparavs);
-                          { Insert hidden parameters }
-                          handle_calling_convention(writeprocdef);
-                          { search procdefs matching writeprocdef }
-                          { skip hidden part (same as for _READ part ) because of the }
-                          { possible different calling conventions and especialy for  }
-                          { records - their methods hidden parameters are handled     }
-                          { after the full record parse                               }
-                          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,cpo_ignorehidden])
-                          else
-                            p.propaccesslist[palt_write].procdef:=Tprocsym(sym).Find_procdef_bypara(writeprocdef.paras,writeprocdef.returndef,[cpo_allowdefaults,cpo_ignorehidden]);
-                          if not assigned(p.propaccesslist[palt_write].procdef) or
-                             { because of cpo_ignorehidden we need to compare if it is a static class method and we have a class property }
-                             ((sp_static in p.symoptions) <> tprocdef(p.propaccesslist[palt_write].procdef).no_self_node) then
-                            Message(parser_e_ill_property_access_sym)
-                          else
-                            begin
-{$ifdef jvm}
-                              orgaccesspd:=tprocdef(p.propaccesslist[palt_write].procdef);
-                              wrongvisibility:=tprocdef(p.propaccesslist[palt_write].procdef).visibility<p.visibility;
-                              if (prop_auto_setter_prefix<>'') and
-                                 ((sym.RealName<>prop_auto_setter_prefix+p.RealName) or
-                                  wrongvisibility) then
-                                jvm_create_setter_for_property(p,orgaccesspd)
-                              { if the visibility of the setter is lower than
-                                the visibility of the property, wrap it so that
-                                we can call it from all contexts in which the
-                                property is visible }
-                              else if wrongvisibility then
-                                begin
-                                  p.propaccesslist[palt_write].procdef:=jvm_wrap_method_with_vis(tprocdef(p.propaccesslist[palt_write].procdef),p.visibility);
-                                  p.propaccesslist[palt_write].firstsym^.sym:=tprocdef(p.propaccesslist[palt_write].procdef).procsym;
-                                end;
-{$endif jvm}
-                            end;
-                        end;
-                      fieldvarsym :
-                        begin
-                          if not assigned(def) then
-                            internalerror(200310072);
-                          if compare_defs(def,p.propdef,nothingn)>=te_equal then
-                           begin
-                             { property parameters are allowed if this is
-                               an indexed property, because the index is then
-                               the parameter.
-                               Note: In the help of Kylix it is written
-                               that it isn't allowed, but the compiler accepts it (PFV) }
-                             if (ppo_hasparameters in p.propoptions) or
-                                ((sp_static in p.symoptions) <> (sp_static in sym.symoptions)) then
-                              Message(parser_e_ill_property_access_sym);
-{$ifdef jvm}
-                             { if the visibility of the field is lower than the
-                               visibility of the property, wrap it in a getter
-                               so that we can access it from all contexts in
-                               which the property is visibile }
-                             if (prop_auto_setter_prefix<>'') or
-                                (tfieldvarsym(sym).visibility<p.visibility) then
-                               jvm_create_setter_for_property(p,nil);
-{$endif}
-                           end
-                          else
-                           IncompatibleTypes(def,p.propdef);
-                        end;
-                      else
-                        Message(parser_e_ill_property_access_sym);
-                    end;
+                    if sym.typ=procsym then
+                      begin
+                        { settter is a procedure with an extra value parameter
+                          of the of the property }
+                        writeprocdef.returndef:=voidtype;
+                        inc(paranr);
+                        hparavs:=cparavarsym.create('$value',10*paranr,vs_value,p.propdef,[]);
+                        writeprocdef.parast.insert(hparavs);
+                        { Insert hidden parameters }
+                        handle_calling_convention(writeprocdef);
+                      end;
+                    p.add_getter_or_setter_for_sym(palt_write,sym,def,writeprocdef);
                   end;
                end;
            end

compiler/symsym.pas

@@ -317,6 +317,9 @@ interface
        tpropaccesslisttypes=(palt_none,palt_read,palt_write,palt_stored);
 
        tpropertysym = class(Tstoredsym)
+         protected
+           procedure finalize_getter_or_setter_for_sym(getset: tpropaccesslisttypes; sym: tsym; fielddef: tdef; accessordef: tprocdef); virtual;
+         public
           propoptions   : tpropertyoptions;
           overriddenpropsym : tpropertysym;
           overriddenpropsymderef : tderef;
@@ -344,6 +347,8 @@ interface
           procedure makeduplicate(p: tpropertysym; readprocdef, writeprocdef: tprocdef; out paranr: word);
           procedure add_accessor_parameters(readprocdef, writeprocdef: tprocdef);
           procedure add_index_parameter(var paranr: word; readprocdef, writeprocdef: tprocdef);
+          { set up the accessors for this property }
+          procedure add_getter_or_setter_for_sym(getset: tpropaccesslisttypes; sym: tsym; fielddef: tdef; accessordef: tprocdef);
        end;
        tpropertysymclass = class of tpropertysym;
 
@@ -1228,6 +1233,12 @@ implementation
                                 TPROPERTYSYM
 ****************************************************************************}
 
+    procedure tpropertysym.finalize_getter_or_setter_for_sym(getset: tpropaccesslisttypes; sym: tsym; fielddef: tdef; accessordef: tprocdef);
+      begin
+        { do nothing by default }
+      end;
+
+
     constructor tpropertysym.create(const n : string);
       var
         pap : tpropaccesslisttypes;
@@ -1376,6 +1387,55 @@ implementation
       end;
 
 
+    procedure tpropertysym.add_getter_or_setter_for_sym(getset: tpropaccesslisttypes; sym: tsym; fielddef: tdef; accessordef: tprocdef);
+      var
+        cpo: tcompare_paras_options;
+      begin
+        case sym.typ of
+          procsym :
+            begin
+              { search procdefs matching accessordef }
+              { we ignore hidden stuff here because the property access symbol might have
+                non default calling conventions which might change the hidden stuff;
+                see tw3216.pp (FK) }
+              cpo:=[cpo_allowdefaults,cpo_ignorehidden];
+              { allow var-parameters for setters in case of VARPROPSETTER+ }
+              if (getset=palt_write) and
+                 (cs_varpropsetter in current_settings.localswitches) then
+                include(cpo,cpo_ignorevarspez);
+              propaccesslist[getset].procdef:=tprocsym(sym).find_procdef_bypara(accessordef.paras,accessordef.returndef,cpo);
+              if not assigned(propaccesslist[getset].procdef) or
+                 { because of cpo_ignorehidden we need to compare if it is a static class method and we have a class property }
+                 ((sp_static in symoptions)<>tprocdef(propaccesslist[getset].procdef).no_self_node) then
+                Message(parser_e_ill_property_access_sym)
+              else
+                finalize_getter_or_setter_for_sym(getset,sym,fielddef,accessordef);
+            end;
+          fieldvarsym :
+            begin
+              if not assigned(fielddef) then
+                internalerror(200310071);
+              if compare_defs(fielddef,propdef,nothingn)>=te_equal then
+               begin
+                 { property parameters are allowed if this is
+                   an indexed property, because the index is then
+                   the parameter.
+                   Note: In the help of Kylix it is written
+                   that it isn't allowed, but the compiler accepts it (PFV) }
+                 if (ppo_hasparameters in propoptions) or
+                    ((sp_static in symoptions) <> (sp_static in sym.symoptions)) then
+                   Message(parser_e_ill_property_access_sym)
+                 else
+                   finalize_getter_or_setter_for_sym(getset,sym,fielddef,accessordef);
+               end
+              else
+               IncompatibleTypes(fielddef,propdef);
+            end;
+          else
+            Message(parser_e_ill_property_access_sym);
+        end;
+      end;
+
 
     procedure tpropertysym.makeduplicate(p: tpropertysym; readprocdef, writeprocdef: tprocdef; out paranr: word);
       begin