From 005bdc1af48600b41d46193ce459d6169fe578a7 Mon Sep 17 00:00:00 2001
From: Jonas Maebe <jonas@freepascal.org>
Date: Fri, 7 Mar 2008 19:29:40 +0000
Subject: [PATCH]   * fixed "inherited some_property" constructs for
 getters/setters     (mantis #10927)   * extended the tb0259 test a bit (tests
 similar constructs in     case there is no getter/setter)

git-svn-id: trunk@10456 -
---
 .gitattributes          |  1 +
 compiler/pexpr.pas      | 28 ++++++++++++++++++--
 tests/tbs/tb0259.pp     | 21 +++++++++++++--
 tests/webtbs/tw10927.pp | 57 +++++++++++++++++++++++++++++++++++++++++
 4 files changed, 103 insertions(+), 4 deletions(-)
 create mode 100644 tests/webtbs/tw10927.pp

diff --git a/.gitattributes b/.gitattributes
index ff3b657e83..a9395282e5 100644
--- a/.gitattributes
+++ b/.gitattributes
@@ -8008,6 +8008,7 @@ tests/webtbs/tw10897.pp svneol=native#text/plain
 tests/webtbs/tw1090.pp svneol=native#text/plain
 tests/webtbs/tw1092.pp svneol=native#text/plain
 tests/webtbs/tw10920.pp svneol=native#text/plain
+tests/webtbs/tw10927.pp svneol=native#text/plain
 tests/webtbs/tw10931.pp svneol=native#text/plain
 tests/webtbs/tw1096.pp svneol=native#text/plain
 tests/webtbs/tw10966.pp svneol=native#text/plain
diff --git a/compiler/pexpr.pas b/compiler/pexpr.pas
index 7182b96334..bf7a038689 100644
--- a/compiler/pexpr.pas
+++ b/compiler/pexpr.pas
@@ -1062,6 +1062,21 @@ implementation
                      fieldvarsym :
                        begin
                          { generate access code }
+
+                         { for fieldvars, having a typenode is wrong:   }
+                         { fields cannot be overridden/hidden in child  }
+                         { classes. However, we always have to pass the }
+                         { typenode to handle_propertysym because the   }
+                         { parent doesn't know yet to what the property }
+                         { will resolve (and in case of procsyms, we do }
+                         { need the type node in case of                }
+                         { "inherited property_with_getter/setter"      }
+                         if (assigned(p1)) and
+                            (p1.nodetype = typen) then
+                           begin
+                             p1.free;
+                             p1:=nil;
+                           end;
                          propaccesslist_to_node(p1,st,propaccesslist);
                          include(p1.flags,nf_isproperty);
                          consume(_ASSIGNMENT);
@@ -1090,6 +1105,15 @@ implementation
                      fieldvarsym :
                        begin
                           { generate access code }
+
+                          { for fieldvars, having a typenode is wrong:   }
+                          { see comments above for write access          }
+                          if (assigned(p1)) and
+                             (p1.nodetype = typen) then
+                            begin
+                              p1.free;
+                              p1:=nil;
+                            end;
                           propaccesslist_to_node(p1,st,propaccesslist);
                           include(p1.flags,nf_isproperty);
                        end;
@@ -2234,14 +2258,14 @@ implementation
                        not from self }
                      if srsym.typ in [procsym,propertysym] then
                       begin
+                        hdef:=hclassdef;
                         if (srsym.typ = procsym) then
                           begin
-                            hdef:=hclassdef;
                             if (po_classmethod in current_procinfo.procdef.procoptions) or
                                (po_staticmethod in current_procinfo.procdef.procoptions) then
                               hdef:=tclassrefdef.create(hdef);
-                            p1:=ctypenode.create(hdef);
                           end;
+                        p1:=ctypenode.create(hdef);
                       end
                      else
                       begin
diff --git a/tests/tbs/tb0259.pp b/tests/tbs/tb0259.pp
index 1f540903fc..c436bb60c3 100644
--- a/tests/tbs/tb0259.pp
+++ b/tests/tbs/tb0259.pp
@@ -5,18 +5,35 @@
 type
   c1=class
     Ffont : longint;
-    property Font:longint read Ffont;
+    property Font:longint read Ffont write Ffont;
   end;
 
   c2=class(c1)
     function GetFont:longint;
+    procedure setfont(l: longint);
   end;
 
 function c2.GetFont:longint;
 begin
-  result:=Font;
   result:=inherited Font;
 end;
 
+
+procedure c2.SetFont(l: longint);
 begin
+  inherited font := l;  
+end;
+
+var
+  c: c2;
+begin
+  c:=c2.create;
+  c.ffont:=5;
+  if c.getfont<>5 then
+    halt(1);
+  c.setfont(10);
+  if c.getfont<>10 then
+    halt(2);
+  if c.ffont<>10 then
+    halt(3);
 end.
diff --git a/tests/webtbs/tw10927.pp b/tests/webtbs/tw10927.pp
new file mode 100644
index 0000000000..8dd985b5bd
--- /dev/null
+++ b/tests/webtbs/tw10927.pp
@@ -0,0 +1,57 @@
+program project1;
+
+{$mode objfpc}{$H+}
+
+type
+
+  { TOrgObject }
+
+  TOriginal=class
+  protected
+    procedure SetReadOnly(const AValue: boolean); virtual;
+  public
+    property readonly:boolean write SetReadOnly;
+  end;
+
+  { TDerived }
+
+  TDerived=class(TOriginal)
+  protected
+    procedure SetReadOnly(const AValue: boolean); override;
+  end;
+
+var
+ count1, count2: longint;
+
+{ TDerived }
+
+procedure TDerived.SetReadOnly(const AValue: boolean);
+begin
+  if (count2>0) then
+    halt(1);
+  inc(count2);
+  WriteLn('TDerived.SetReadOnly');
+  inherited;
+  inherited ReadOnly := AValue;
+end;
+
+{ TOrgObject }
+
+procedure TOriginal.SetReadOnly(const AValue: boolean);
+begin
+  if (count1>1) then
+    halt(2);
+  inc(count1);
+  WriteLn('TOriginal.SetReadOnly');
+end;
+
+var
+  D: TDerived;
+begin
+  D := TDerived.Create;
+  D.ReadOnly := True;
+  D.Free;
+  if (count1<>2) or
+     (count2<>1) then
+    halt(3);
+end.