From 8634aa8ad200e09786e033c711a87b66cd5081ad Mon Sep 17 00:00:00 2001
From: Jonas Maebe <jonas@freepascal.org>
Date: Sat, 14 Jun 2014 10:35:35 +0000
Subject: [PATCH]   * fixes for the support for overriding properties on the
 JVM target:    o only create an accessor wrapping the inherited accessor at a
      potentially lower visibility level if the overriding property     
 itself does not specify a different accessor to use    o simplified code    o
 tests

git-svn-id: trunk@27954 -
---
 .gitattributes             |  2 ++
 compiler/jvm/symcpu.pas    | 60 ++++++++++++++------------------------
 compiler/pdecvar.pas       |  8 +++--
 compiler/symsym.pas        | 10 ++++++-
 tests/test/jvm/testall.bat |  4 +++
 tests/test/jvm/testall.sh  |  4 +++
 tests/test/jvm/tprop6.pp   | 40 +++++++++++++++++++++++++
 tests/test/jvm/tprop6a.pp  | 16 ++++++++++
 8 files changed, 103 insertions(+), 41 deletions(-)
 create mode 100644 tests/test/jvm/tprop6.pp
 create mode 100644 tests/test/jvm/tprop6a.pp

diff --git a/.gitattributes b/.gitattributes
index 607265ddc1..c4db6b0968 100644
--- a/.gitattributes
+++ b/.gitattributes
@@ -10908,6 +10908,8 @@ tests/test/jvm/tprop3.pp svneol=native#text/plain
 tests/test/jvm/tprop4.pp svneol=native#text/plain
 tests/test/jvm/tprop5.pp svneol=native#text/plain
 tests/test/jvm/tprop5a.pp svneol=native#text/plain
+tests/test/jvm/tprop6.pp svneol=native#text/plain
+tests/test/jvm/tprop6a.pp svneol=native#text/plain
 tests/test/jvm/tptrdynarr.pp svneol=native#text/plain
 tests/test/jvm/tpvar.pp svneol=native#text/plain
 tests/test/jvm/tpvardelphi.pp svneol=native#text/plain
diff --git a/compiler/jvm/symcpu.pas b/compiler/jvm/symcpu.pas
index 573bd03a73..0c9290c995 100644
--- a/compiler/jvm/symcpu.pas
+++ b/compiler/jvm/symcpu.pas
@@ -187,10 +187,11 @@ type
       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 }
-    function create_getter_or_setter_for_property(orgaccesspd: tprocdef; getter: boolean): tprocdef;
+    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;
-    procedure register_override(overriddenprop: tpropertysym); override;
     procedure maybe_create_overridden_getter_or_setter(getset: tpropaccesslisttypes);
+   public
+    procedure inherit_accessor(getset: tpropaccesslisttypes); override;
   end;
   tcpupropertysymclass = class of tcpupropertysym;
 
@@ -224,7 +225,7 @@ implementation
                                tcpuproptertysym
   ****************************************************************************}
 
-  function tcpupropertysym.create_getter_or_setter_for_property(orgaccesspd: tprocdef; getter: boolean): tprocdef;
+  procedure tcpupropertysym.create_getter_or_setter_for_property(orgaccesspd: tprocdef; getter: boolean);
     var
       obj: tabstractrecorddef;
       ps: tprocsym;
@@ -311,7 +312,6 @@ implementation
                             parentpd.visibility:=visibility;
                             include(parentpd.procoptions,po_auto_raised_visibility);
                           end;
-                        result:=parentpd;
                         { we are done, no need to create a wrapper }
                         exit
                       end
@@ -344,7 +344,10 @@ implementation
                     finish_copied_procdef(pd,parentpd.procsym.realname,obj.symtable,obj);
                     exclude(pd.procoptions,po_external);
                     pd.synthetickind:=tsk_anon_inherited;
-                    result:=pd;
+                    { set the accessor in the property }
+                    propaccesslist[accesstyp].clear;
+                    propaccesslist[accesstyp].addsym(sl_call,pd.procsym);
+                    propaccesslist[accesstyp].procdef:=pd;
                     exit;
                   end;
               end;
@@ -400,7 +403,6 @@ implementation
         pd.procoptions:=pd.procoptions+procoptions;
         { visibility }
         pd.visibility:=visibility;
-        result:=pd;
 
         { new procsym? }
         if not assigned(sym) or
@@ -501,7 +503,7 @@ implementation
 
   procedure tcpupropertysym.finalize_getter_or_setter_for_sym(getset: tpropaccesslisttypes; sym: tsym; fielddef: tdef; accessordef: tprocdef);
     var
-      orgaccesspd, newaccesspd: tprocdef;
+      orgaccesspd: tprocdef;
       pprefix: pshortstring;
       wrongvisibility: boolean;
     begin
@@ -510,7 +512,6 @@ implementation
         pprefix:=@prop_auto_getter_prefix
       else
         pprefix:=@prop_auto_setter_prefix;
-      newaccesspd:=nil;
       case sym.typ of
         procsym:
           begin
@@ -523,7 +524,7 @@ implementation
             if wrongvisibility or
                ((pprefix^<>'') and
                 (sym.RealName<>pprefix^+RealName)) then
-              newaccesspd:=create_getter_or_setter_for_property(orgaccesspd,getset=palt_read)
+              create_getter_or_setter_for_property(orgaccesspd,getset=palt_read)
           end;
         fieldvarsym:
           begin
@@ -533,43 +534,17 @@ implementation
               which the property is visibile }
             if (pprefix^<>'') or
                (tfieldvarsym(sym).visibility<visibility) then
-              newaccesspd:=create_getter_or_setter_for_property(nil,getset=palt_read);
+              create_getter_or_setter_for_property(nil,getset=palt_read);
           end;
         else
           internalerror(2014061101);
       end;
-      { update the getter/setter used for this property (already done in case
-        a new method was created from scratch, but not if we overrode a
-        getter/setter generated for the inherited property) }
-      if assigned(newaccesspd) then
-        begin
-          if propaccesslist[getset].firstsym^.sym.typ<>procsym then
-            internalerror(2014061201);
-          propaccesslist[getset].procdef:=newaccesspd;
-          propaccesslist[getset].firstsym^.sym:=newaccesspd.procsym;
-        end;
-    end;
-
-
-  procedure tcpupropertysym.register_override(overriddenprop: tpropertysym);
-    var
-      sym: tsym;
-    begin
-      inherited;
-      { new property has higher visibility than previous one -> maybe override
-        the getters/setters }
-      if (overriddenprop.visibility<visibility) then
-        begin
-          maybe_create_overridden_getter_or_setter(palt_read);
-          maybe_create_overridden_getter_or_setter(palt_write);
-        end;
     end;
 
 
   procedure tcpupropertysym.maybe_create_overridden_getter_or_setter(getset: tpropaccesslisttypes);
     var
       sym: tsym;
-      fielddef: tdef;
       accessordef: tprocdef;
       psym: tpropertysym;
     begin
@@ -590,14 +565,12 @@ implementation
             accessordef:=tprocdef(psym.propaccesslist[getset].procdef);
             if accessordef.visibility>=visibility then
               exit;
-            fielddef:=nil;
           end;
         fieldvarsym:
           begin
             if sym.visibility>=visibility then
               exit;
             accessordef:=nil;
-            fielddef:=tfieldvarsym(sym).vardef;
           end;
         else
           internalerror(2014061102);
@@ -607,6 +580,17 @@ implementation
     end;
 
 
+  procedure tcpupropertysym.inherit_accessor(getset: tpropaccesslisttypes);
+    begin
+      inherited;
+      { new property has higher visibility than previous one -> maybe override
+        the getters/setters }
+      if assigned(overriddenpropsym) and
+         (overriddenpropsym.visibility<visibility) then
+        maybe_create_overridden_getter_or_setter(getset);
+    end;
+
+
 {****************************************************************************
                              tcpuenumdef
 ****************************************************************************}
diff --git a/compiler/pdecvar.pas b/compiler/pdecvar.pas
index cb32b5ad89..2f9f07ee89 100644
--- a/compiler/pdecvar.pas
+++ b/compiler/pdecvar.pas
@@ -535,7 +535,9 @@ implementation
                       end;
                     p.add_getter_or_setter_for_sym(palt_read,sym,def,readprocdef);
                   end;
-               end;
+               end
+             else
+               p.inherit_accessor(palt_read);
              if try_to_consume(_WRITE) then
                begin
                  p.propaccesslist[palt_write].clear;
@@ -555,7 +557,9 @@ implementation
                       end;
                     p.add_getter_or_setter_for_sym(palt_write,sym,def,writeprocdef);
                   end;
-               end;
+               end
+             else
+               p.inherit_accessor(palt_write);
            end
          else
            parse_dispinterface(p,readprocdef,writeprocdef,paranr);
diff --git a/compiler/symsym.pas b/compiler/symsym.pas
index d5d208ad45..6f7b88432a 100644
--- a/compiler/symsym.pas
+++ b/compiler/symsym.pas
@@ -349,7 +349,9 @@ interface
           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);
-          procedure register_override(overriddenprop: tpropertysym); virtual;
+          procedure register_override(overriddenprop: tpropertysym);
+          { inherit the read/write property }
+          procedure inherit_accessor(getset: tpropaccesslisttypes); virtual;
        end;
        tpropertysymclass = class of tpropertysym;
 
@@ -1445,6 +1447,12 @@ implementation
       end;
 
 
+    procedure tpropertysym.inherit_accessor(getset: tpropaccesslisttypes);
+      begin
+        { nothing to do by default }
+      end;
+
+
     procedure tpropertysym.makeduplicate(p: tpropertysym; readprocdef, writeprocdef: tprocdef; out paranr: word);
       begin
         { inherit all type related entries }
diff --git a/tests/test/jvm/testall.bat b/tests/test/jvm/testall.bat
index 09c37e3b74..22dd423911 100644
--- a/tests/test/jvm/testall.bat
+++ b/tests/test/jvm/testall.bat
@@ -298,3 +298,7 @@ ppcjvm -O2 -g -B -Sa tprop5a
 java -Dfile.encoding=UTF-8 -cp ..\..\..\rtl\units\jvm-java;. tprop5a
 ppcjvm -O2 -g -B -Sa tprop5a -CTautosetterprefix=Set -CTautogetterprefix=Get
 java -Dfile.encoding=UTF-8 -cp ..\..\..\rtl\units\jvm-java;. tprop5a
+ppcjvm -O2 -g -B -Sa tprop6a
+java -Dfile.encoding=UTF-8 -cp ..\..\..\rtl\units\jvm-java;. tprop6a
+ppcjvm -O2 -g -B -Sa tprop6a -CTautosetterprefix=Set -CTautogetterprefix=Get
+java -Dfile.encoding=UTF-8 -cp ..\..\..\rtl\units\jvm-java;. tprop6a
diff --git a/tests/test/jvm/testall.sh b/tests/test/jvm/testall.sh
index 84dd49c55b..5feb130a08 100755
--- a/tests/test/jvm/testall.sh
+++ b/tests/test/jvm/testall.sh
@@ -178,3 +178,7 @@ $PPC -O2 -g -B -Sa tprop5a
 java -Dfile.encoding=UTF-8 -cp ../../../rtl/units/$RTLDIR:. tprop5a
 $PPC -O2 -g -B -Sa tprop5a -CTautosetterprefix=Set -CTautogetterprefix=Get
 java -Dfile.encoding=UTF-8 -cp ../../../rtl/units/$RTLDIR:. tprop5a
+$PPC -O2 -g -B -Sa tprop6a
+java -Dfile.encoding=UTF-8 -cp ../../../rtl/units/$RTLDIR:. tprop6a
+$PPC -O2 -g -B -Sa tprop6a -CTautosetterprefix=Set -CTautogetterprefix=Get
+java -Dfile.encoding=UTF-8 -cp ../../../rtl/units/$RTLDIR:. tprop6a
diff --git a/tests/test/jvm/tprop6.pp b/tests/test/jvm/tprop6.pp
new file mode 100644
index 0000000000..778739b5a1
--- /dev/null
+++ b/tests/test/jvm/tprop6.pp
@@ -0,0 +1,40 @@
+{$mode delphi}
+{$modeswitch unicodestrings}
+{$namespace org.freepascal.test}
+
+Unit tprop6;
+
+interface
+
+uses
+ jdk15;
+
+type
+ TBaseClassProp6 = class
+ private
+   FLevel : integer;
+   procedure SetLevel(value: integer); virtual;
+ public
+   property Level: Integer read FLevel write SetLevel;
+ end;
+
+ TDerivedClassProp6 = class(TBaseClassProp6)
+ protected
+   procedure SetLevel(value: integer); override;
+ public
+   property Level: Integer read FLevel write SetLevel;
+ end;
+
+implementation
+
+procedure TBaseClassProp6.SetLevel(Value: integer);
+begin
+ FLevel := Value;
+end;
+
+procedure TDerivedClassProp6.SetLevel(Value: integer);
+begin
+ FLevel := Value+1;
+end;
+
+end.
diff --git a/tests/test/jvm/tprop6a.pp b/tests/test/jvm/tprop6a.pp
new file mode 100644
index 0000000000..d0430c2932
--- /dev/null
+++ b/tests/test/jvm/tprop6a.pp
@@ -0,0 +1,16 @@
+program tprop6a;
+
+uses
+  tprop6;
+var
+  c: tbaseclassprop6;
+  d: tderivedclassprop6;
+begin
+  c:=tbaseclassprop6.create;
+  c.level:=4;
+  if c.level<>4 then
+    halt(1);
+  d:=tderivedclassprop6.create;
+  d.level:=5;
+  halt(d.level-6);
+end.