From 570f3c4b396872d46c922e160e1c75a87e27e9fb Mon Sep 17 00:00:00 2001
From: florian <florian@freepascal.org>
Date: Thu, 30 Jun 2011 18:54:46 +0000
Subject: [PATCH] * merges recent class helper fixes by Sven Barth

git-svn-id: trunk@17887 -
---
 .gitattributes        |  7 +++++++
 compiler/dbgdwarf.pas |  6 ++++--
 compiler/htypechk.pas | 16 +++++++++++++++
 compiler/ncal.pas     |  9 ++++++++-
 compiler/pstatmnt.pas | 45 +++++++++++++++++++++++++++++++++++++++++++
 compiler/symdef.pas   |  2 +-
 compiler/symtable.pas |  1 +
 tests/test/tchlp55.pp | 21 ++++++++++++++++++++
 tests/test/tchlp56.pp | 21 ++++++++++++++++++++
 tests/test/tchlp57.pp | 24 +++++++++++++++++++++++
 tests/test/tchlp58.pp | 24 +++++++++++++++++++++++
 tests/test/thlp45.pp  | 39 +++++++++++++++++++++++++++++++++++++
 tests/test/trhlp42.pp | 27 ++++++++++++++++++++++++++
 tests/test/trhlp43.pp | 25 ++++++++++++++++++++++++
 14 files changed, 263 insertions(+), 4 deletions(-)
 create mode 100644 tests/test/tchlp55.pp
 create mode 100644 tests/test/tchlp56.pp
 create mode 100644 tests/test/tchlp57.pp
 create mode 100644 tests/test/tchlp58.pp
 create mode 100644 tests/test/thlp45.pp
 create mode 100644 tests/test/trhlp42.pp
 create mode 100644 tests/test/trhlp43.pp

diff --git a/.gitattributes b/.gitattributes
index f59f5f667f..c11d401ed7 100644
--- a/.gitattributes
+++ b/.gitattributes
@@ -9846,6 +9846,10 @@ tests/test/tchlp51.pp svneol=native#text/pascal
 tests/test/tchlp52.pp svneol=native#text/pascal
 tests/test/tchlp53.pp svneol=native#text/pascal
 tests/test/tchlp54.pp svneol=native#text/pascal
+tests/test/tchlp55.pp svneol=native#text/pascal
+tests/test/tchlp56.pp svneol=native#text/pascal
+tests/test/tchlp57.pp svneol=native#text/pascal
+tests/test/tchlp58.pp svneol=native#text/pascal
 tests/test/tchlp6.pp svneol=native#text/pascal
 tests/test/tchlp7.pp svneol=native#text/pascal
 tests/test/tchlp8.pp svneol=native#text/pascal
@@ -10055,6 +10059,7 @@ tests/test/thlp41.pp svneol=native#text/pascal
 tests/test/thlp42.pp svneol=native#text/pascal
 tests/test/thlp43.pp svneol=native#text/pascal
 tests/test/thlp44.pp svneol=native#text/pascal
+tests/test/thlp45.pp svneol=native#text/pascal
 tests/test/thlp5.pp svneol=native#text/pascal
 tests/test/thlp6.pp svneol=native#text/pascal
 tests/test/thlp7.pp svneol=native#text/pascal
@@ -10364,6 +10369,8 @@ tests/test/trhlp39.pp svneol=native#text/pascal
 tests/test/trhlp4.pp svneol=native#text/pascal
 tests/test/trhlp40.pp svneol=native#text/pascal
 tests/test/trhlp41.pp svneol=native#text/pascal
+tests/test/trhlp42.pp svneol=native#text/pascal
+tests/test/trhlp43.pp svneol=native#text/pascal
 tests/test/trhlp5.pp svneol=native#text/pascal
 tests/test/trhlp6.pp svneol=native#text/pascal
 tests/test/trhlp7.pp svneol=native#text/pascal
diff --git a/compiler/dbgdwarf.pas b/compiler/dbgdwarf.pas
index 0b887fca2e..bf95586ddd 100644
--- a/compiler/dbgdwarf.pas
+++ b/compiler/dbgdwarf.pas
@@ -922,7 +922,7 @@ implementation
                       internalerror(200610011);
                     def.dwarf_lab:=current_asmdata.RefAsmSymbol(make_mangledname('DBG',def.owner,symname(def.typesym)));
                     def.dwarf_ref_lab:=current_asmdata.RefAsmSymbol(make_mangledname('DBGREF',def.owner,symname(def.typesym)));
-                    if is_class_or_interface_or_dispinterface(def) then
+                    if is_class_or_interface_or_dispinterface(def) or is_objectpascal_helper(def) then
                       tobjectdef(def).dwarf_struct_lab:=current_asmdata.RefAsmSymbol(make_mangledname('DBG2',def.owner,symname(def.typesym)));
                     def.dbg_state:=dbg_state_written;
                   end
@@ -936,7 +936,7 @@ implementation
                       begin
                         def.dwarf_lab:=current_asmdata.DefineAsmSymbol(make_mangledname('DBG',def.owner,symname(def.typesym)),AB_GLOBAL,AT_DATA);
                         def.dwarf_ref_lab:=current_asmdata.DefineAsmSymbol(make_mangledname('DBGREF',def.owner,symname(def.typesym)),AB_GLOBAL,AT_DATA);
-                        if is_class_or_interface_or_dispinterface(def) then
+                        if is_class_or_interface_or_dispinterface(def) or is_objectpascal_helper(def) then
                           tobjectdef(def).dwarf_struct_lab:=current_asmdata.DefineAsmSymbol(make_mangledname('DBG2',def.owner,symname(def.typesym)),AB_GLOBAL,AT_DATA);
                         include(def.defstates,ds_dwarf_dbg_info_written);
                       end
@@ -3541,6 +3541,7 @@ implementation
           odt_interfacecom,
           odt_interfacecorba,
           odt_dispinterface,
+          odt_helper,
           odt_class:
             begin
               { implicit pointer }
@@ -3948,6 +3949,7 @@ implementation
               dostruct(DW_TAG_interface_type);
               doparent(true);
             end;
+          odt_helper,
           odt_class:
             begin
               //dostruct(DW_TAG_class_type);
diff --git a/compiler/htypechk.pas b/compiler/htypechk.pas
index b298ac9eab..3604e2c00d 100644
--- a/compiler/htypechk.pas
+++ b/compiler/htypechk.pas
@@ -1865,6 +1865,22 @@ implementation
                if not hasoverload then
                  break;
              end;
+           if is_objectpascal_helper(structdef) then
+             begin
+               if not assigned(tobjectdef(structdef).extendeddef) then
+                 Internalerror(2011062601);
+               { search methods in the extended type as well }
+               srsym:=tprocsym(tobjectdef(structdef).extendeddef.symtable.FindWithHash(hashedid));
+               if assigned(srsym) and
+                  { Delphi allows hiding a property by a procedure with the same name }
+                  (srsym.typ=procsym) then
+                 begin
+                   hasoverload:=processprocsym(tprocsym(srsym));
+                   { when there is no explicit overload we stop searching }
+                   if not hasoverload then
+                     break;
+                 end;
+             end;
            { next parent }
            if (structdef.typ=objectdef) then
              structdef:=tobjectdef(structdef).childof
diff --git a/compiler/ncal.pas b/compiler/ncal.pas
index 299d7287f1..de8b12140b 100644
--- a/compiler/ncal.pas
+++ b/compiler/ncal.pas
@@ -1638,6 +1638,7 @@ implementation
     function tcallnode.gen_self_tree:tnode;
       var
         selftree : tnode;
+        selfdef  : tabstractrecorddef;
       begin
         selftree:=nil;
 
@@ -1685,7 +1686,13 @@ implementation
             begin
               if (procdefinition.typ<>procdef) then
                 internalerror(200305062);
-              if (oo_has_vmt in tprocdef(procdefinition).struct.objectoptions) then
+              { if the method belongs to a helper then we need to use the
+                extended type for references to Self }
+              if is_objectpascal_helper(tprocdef(procdefinition).struct) then
+                selfdef:=tobjectdef(tprocdef(procdefinition).struct).extendeddef
+              else
+                selfdef:=tprocdef(procdefinition).struct;
+              if (oo_has_vmt in selfdef.objectoptions) then
                 begin
                   { we only need the vmt, loading self is not required and there is no
                     need to check for typen, because that will always get the
diff --git a/compiler/pstatmnt.pas b/compiler/pstatmnt.pas
index 9a42188c16..a8127da398 100644
--- a/compiler/pstatmnt.pas
+++ b/compiler/pstatmnt.pas
@@ -516,19 +516,36 @@ implementation
          hp,
          refnode  : tnode;
          hdef : tdef;
+         extendeddef : tabstractrecorddef;
+         helperdef : tobjectdef;
          hasimplicitderef : boolean;
          withsymtablelist : TFPObjectList;
 
          procedure pushobjchild(withdef,obj:tobjectdef);
+         var
+           parenthelperdef : tobjectdef;
          begin
            if not assigned(obj) then
              exit;
            pushobjchild(withdef,obj.childof);
+           { we need to look for helpers that were defined for the parent
+             class as well }
+           search_last_objectpascal_helper(obj,current_structdef,parenthelperdef);
+           { push the symtables of the helper's parents in reverse order }
+           if assigned(parenthelperdef) then
+             pushobjchild(withdef,parenthelperdef.childof);
            { keep the original tobjectdef as owner, because that is used for
              visibility of the symtable }
            st:=twithsymtable.create(withdef,obj.symtable.SymList,refnode.getcopy);
            symtablestack.push(st);
            withsymtablelist.add(st);
+           { push the symtable of the helper }
+           if assigned(parenthelperdef) then
+             begin
+               st:=twithsymtable.create(withdef,parenthelperdef.symtable.SymList,refnode.getcopy);
+               symtablestack.push(st);
+               withsymtablelist.add(st);
+             end;
          end;
 
 
@@ -625,12 +642,25 @@ implementation
                 typecheckpass(refnode);
               end;
 
+            { do we have a helper for this type? }
+            if p.resultdef.typ=classrefdef then
+              extendeddef:=tobjectdef(tclassrefdef(p.resultdef).pointeddef)
+            else
+              extendeddef:=tabstractrecorddef(p.resultdef);
+            search_last_objectpascal_helper(extendeddef,current_structdef,helperdef);
+            { Note: the symtable of the helper is pushed after the following
+                    "case", the symtables of the helper's parents are passed in
+                    the "case" branches }
+
             withsymtablelist:=TFPObjectList.create(true);
             case p.resultdef.typ of
               objectdef :
                 begin
                    { push symtables of all parents in reverse order }
                    pushobjchild(tobjectdef(p.resultdef),tobjectdef(p.resultdef).childof);
+                   { push symtables of all parents of the helper in reverse order }
+                   if assigned(helperdef) then
+                     pushobjchild(helperdef,helperdef.childof);
                    { push object symtable }
                    st:=twithsymtable.Create(tobjectdef(p.resultdef),tobjectdef(p.resultdef).symtable.SymList,refnode);
                    symtablestack.push(st);
@@ -640,6 +670,9 @@ implementation
                 begin
                    { push symtables of all parents in reverse order }
                    pushobjchild(tobjectdef(tclassrefdef(p.resultdef).pointeddef),tobjectdef(tclassrefdef(p.resultdef).pointeddef).childof);
+                   { push symtables of all parents of the helper in reverse order }
+                   if assigned(helperdef) then
+                     pushobjchild(helperdef,helperdef.childof);
                    { push object symtable }
                    st:=twithsymtable.Create(tobjectdef(tclassrefdef(p.resultdef).pointeddef),tobjectdef(tclassrefdef(p.resultdef).pointeddef).symtable.SymList,refnode);
                    symtablestack.push(st);
@@ -647,6 +680,10 @@ implementation
                 end;
               recorddef :
                 begin
+                   { push symtables of all parents of the helper in reverse order }
+                   if assigned(helperdef) then
+                     pushobjchild(helperdef,helperdef.childof);
+                   { push record symtable }
                    st:=twithsymtable.create(trecorddef(p.resultdef),trecorddef(p.resultdef).symtable.SymList,refnode);
                    symtablestack.push(st);
                    withsymtablelist.add(st);
@@ -655,6 +692,14 @@ implementation
                 internalerror(200601271);
             end;
 
+            { push helper symtable }
+            if assigned(helperdef) then
+              begin
+                st:=twithsymtable.Create(helperdef,helperdef.symtable.SymList,refnode.getcopy);
+                symtablestack.push(st);
+                withsymtablelist.add(st);
+              end;
+
             if try_to_consume(_COMMA) then
               p:=_with_statement()
             else
diff --git a/compiler/symdef.pas b/compiler/symdef.pas
index ecc5379be6..bc2dcc1a9c 100644
--- a/compiler/symdef.pas
+++ b/compiler/symdef.pas
@@ -5783,7 +5783,7 @@ implementation
         result:=
           assigned(def) and
           (def.typ=objectdef) and
-          (tobjectdef(def).objecttype in [odt_class,odt_interfacecom,odt_interfacecorba,odt_dispinterface,odt_objcclass,odt_objcprotocol]);
+          (tobjectdef(def).objecttype in [odt_class,odt_interfacecom,odt_interfacecorba,odt_dispinterface,odt_objcclass,odt_objcprotocol,odt_helper]);
       end;
 
     function is_class_or_object(def: tdef): boolean;
diff --git a/compiler/symtable.pas b/compiler/symtable.pas
index a85212b43d..610cace6e4 100644
--- a/compiler/symtable.pas
+++ b/compiler/symtable.pas
@@ -2560,6 +2560,7 @@ implementation
         st: tsymtable;
       begin
         result:=false;
+        odef:=nil;
         { when there are no helpers active currently then we don't need to do
           anything }
         if current_module.extendeddefs.count=0 then
diff --git a/tests/test/tchlp55.pp b/tests/test/tchlp55.pp
new file mode 100644
index 0000000000..55fccd6c17
--- /dev/null
+++ b/tests/test/tchlp55.pp
@@ -0,0 +1,21 @@
+{ %NORUN }
+
+{ This tests that methods introduced by a helper can be found in 
+  with-Statements as well - Case 1: normal method in current helper }
+program tchlp55;
+
+{$mode objfpc}
+
+type
+  TObjectHelper = class helper for TObject
+    procedure Test;
+  end;
+
+procedure TObjectHelper.Test;
+begin
+end;
+
+begin
+  with TObject.Create do
+    Test;
+end.
diff --git a/tests/test/tchlp56.pp b/tests/test/tchlp56.pp
new file mode 100644
index 0000000000..f6aa7194f2
--- /dev/null
+++ b/tests/test/tchlp56.pp
@@ -0,0 +1,21 @@
+{ %NORUN }
+
+{ This tests that methods introduced by a helper can be found in 
+  with-Statements as well - Case 2: class method in current helper }
+program tchlp56;
+
+{$mode objfpc}
+
+type
+  TObjectHelper = class helper for TObject
+    class procedure Test;
+  end;
+
+class procedure TObjectHelper.Test;
+begin
+end;
+
+begin
+  with TObject do
+    Test;
+end.
diff --git a/tests/test/tchlp57.pp b/tests/test/tchlp57.pp
new file mode 100644
index 0000000000..fe64057465
--- /dev/null
+++ b/tests/test/tchlp57.pp
@@ -0,0 +1,24 @@
+{ %NORUN }
+
+{ This tests that methods introduced by a helper can be found in 
+  with-Statements as well - Case 3: normal method in parent's helper }
+program tchlp57;
+
+{$mode objfpc}
+
+type
+  TObjectHelper = class helper for TObject
+    procedure Test;
+  end;
+
+  TTest = class
+  end;
+
+procedure TObjectHelper.Test;
+begin
+end;
+
+begin
+  with TTest.Create do
+    Test;
+end.
diff --git a/tests/test/tchlp58.pp b/tests/test/tchlp58.pp
new file mode 100644
index 0000000000..dc96f2ba63
--- /dev/null
+++ b/tests/test/tchlp58.pp
@@ -0,0 +1,24 @@
+{ %NORUN }
+
+{ This tests that methods introduced by a helper can be found in 
+  with-Statements as well - Case 4: class method in parent's helper }
+program tchlp58;
+
+{$mode objfpc}
+
+type
+  TObjectHelper = class helper for TObject
+    class procedure Test;
+  end;
+
+  TTest = class
+  end;
+
+class procedure TObjectHelper.Test;
+begin
+end;
+
+begin
+  with TTest do
+    Test;
+end.
diff --git a/tests/test/thlp45.pp b/tests/test/thlp45.pp
new file mode 100644
index 0000000000..5eefcd93ec
--- /dev/null
+++ b/tests/test/thlp45.pp
@@ -0,0 +1,39 @@
+{ this tests that the correct method is called if a helper overloads an
+  existing function and calls the original one recursively }
+program thlp45;
+
+{$mode objfpc}{$H+}
+
+type
+  TTest = class
+    function Test(aRecurse: Boolean; aTest: String): Integer;
+  end;
+
+  TTestHelper = class helper for TTest
+    function Test(aRecurse: Boolean; aTest: array of String): Integer; overload;
+  end;
+
+function TTest.Test(aRecurse: Boolean; aTest: String): Integer;
+begin
+  Result := 1;
+end;
+
+function TTestHelper.Test(aRecurse: Boolean; aTest: array of String): Integer;
+begin
+  if aRecurse then
+    Result := Test(False, aTest[0])
+  else
+    Result := 2;  
+end;
+
+var
+  t: TTest;
+  res: Integer;
+begin
+  t := TTest.Create;
+  res := t.Test(True, ['Test']);
+  Writeln('t.Test: ', res);
+  if res <> 1 then
+    Halt(1);
+  Writeln('ok');
+end.
diff --git a/tests/test/trhlp42.pp b/tests/test/trhlp42.pp
new file mode 100644
index 0000000000..87d98300a7
--- /dev/null
+++ b/tests/test/trhlp42.pp
@@ -0,0 +1,27 @@
+{ %NORUN }
+
+{ This tests that methods introduced by a helper can be found in 
+  with-Statements as well - Case 1: normal method in current helper }
+program trhlp42;
+
+{$mode objfpc}
+{$modeswitch advancedrecords}
+
+type
+  TTest = record
+  end;
+
+  TTestHelper = record helper for TTest
+    procedure Test;
+  end;
+
+procedure TTestHelper.Test;
+begin
+end;
+
+var
+  t: TTest;
+begin
+  with t do
+    Test;
+end.
diff --git a/tests/test/trhlp43.pp b/tests/test/trhlp43.pp
new file mode 100644
index 0000000000..86220c8c38
--- /dev/null
+++ b/tests/test/trhlp43.pp
@@ -0,0 +1,25 @@
+{ %NORUN }
+
+{ This tests that methods introduced by a helper can be found in 
+  with-Statements as well - Case 2: class method in current helper }
+program trhlp43;
+
+{$mode objfpc}
+{$modeswitch advancedrecords}
+
+type
+  TTest = record
+  end;
+
+  TTestHelper = record helper for TTest
+    class procedure Test; static;
+  end;
+
+class procedure TTestHelper.Test;
+begin
+end;
+
+begin
+  with TTest do
+    Test;
+end.