瀏覽代碼

* inheritance based on message also needs to find hidden
private methods

git-svn-id: trunk@4024 -

peter 19 年之前
父節點
當前提交
172413fd09
共有 4 個文件被更改,包括 78 次插入2 次删除
  1. 2 0
      .gitattributes
  2. 4 2
      compiler/symtable.pas
  3. 28 0
      tests/webtbs/tw6203.pp
  4. 44 0
      tests/webtbs/uw6203.pp

+ 2 - 0
.gitattributes

@@ -7180,6 +7180,7 @@ tests/webtbs/tw5036.pp svneol=native#text/plain
 tests/webtbs/tw5082.pp -text svneol=unset#text/plain
 tests/webtbs/tw5082.pp -text svneol=unset#text/plain
 tests/webtbs/tw5086.pp -text
 tests/webtbs/tw5086.pp -text
 tests/webtbs/tw5094.pp -text
 tests/webtbs/tw5094.pp -text
+tests/webtbs/tw6203.pp svneol=native#text/plain
 tests/webtbs/tw6435.pp svneol=native#text/plain
 tests/webtbs/tw6435.pp svneol=native#text/plain
 tests/webtbs/tw6491.pp svneol=native#text/plain
 tests/webtbs/tw6491.pp svneol=native#text/plain
 tests/webtbs/tw6624.pp svneol=native#text/plain
 tests/webtbs/tw6624.pp svneol=native#text/plain
@@ -7239,6 +7240,7 @@ tests/webtbs/uw4352c.pp svneol=native#text/plain
 tests/webtbs/uw4352d.pp svneol=native#text/plain
 tests/webtbs/uw4352d.pp svneol=native#text/plain
 tests/webtbs/uw4352e.pp svneol=native#text/plain
 tests/webtbs/uw4352e.pp svneol=native#text/plain
 tests/webtbs/uw4541.pp svneol=native#text/plain
 tests/webtbs/uw4541.pp svneol=native#text/plain
+tests/webtbs/uw6203.pp svneol=native#text/plain
 tests/webtbs/uw6767.pp svneol=native#text/plain
 tests/webtbs/uw6767.pp svneol=native#text/plain
 utils/Makefile svneol=native#text/plain
 utils/Makefile svneol=native#text/plain
 utils/Makefile.fpc svneol=native#text/plain
 utils/Makefile.fpc svneol=native#text/plain

+ 4 - 2
compiler/symtable.pas

@@ -1804,8 +1804,9 @@ implementation
             def:=tdef(classh.symtable.defindex.first);
             def:=tdef(classh.symtable.defindex.first);
             while assigned(def) do
             while assigned(def) do
               begin
               begin
+                { Find also all hidden private methods to
+                  be compatible with delphi, see tw6203 (PFV) }
                 if (def.deftype=procdef) and
                 if (def.deftype=procdef) and
-                   tprocdef(def).is_visible_for_object(topclassh) and
                    (po_msgint in tprocdef(def).procoptions) and
                    (po_msgint in tprocdef(def).procoptions) and
                    (tprocdef(def).messageinf.i=i) then
                    (tprocdef(def).messageinf.i=i) then
                   begin
                   begin
@@ -1850,8 +1851,9 @@ implementation
             def:=tdef(classh.symtable.defindex.first);
             def:=tdef(classh.symtable.defindex.first);
             while assigned(def) do
             while assigned(def) do
               begin
               begin
+                { Find also all hidden private methods to
+                  be compatible with delphi, see tw6203 (PFV) }
                 if (def.deftype=procdef) and
                 if (def.deftype=procdef) and
-                   tprocdef(def).is_visible_for_object(topclassh) and
                    (po_msgstr in tprocdef(def).procoptions) and
                    (po_msgstr in tprocdef(def).procoptions) and
                    (tprocdef(def).messageinf.str=s) then
                    (tprocdef(def).messageinf.str=s) then
                   begin
                   begin

+ 28 - 0
tests/webtbs/tw6203.pp

@@ -0,0 +1,28 @@
+{$mode delphi}
+
+uses
+  uw6203;
+
+type
+  TDerived = class(TTest)
+  private
+    procedure CMTest(var Msg: TMessage); message CM_TEST;
+  end;
+
+procedure TDerived.CMTest(var Msg: TMessage);
+begin
+  inherited;
+  WriteLn('TDerived.CMTest');
+end;
+
+var
+  Test: TTest;
+  Msg: TMessage;
+begin
+  err:=true;
+  Test := TDerived.Create;
+  Msg.Msg := CM_TEST;
+  Test.Dispatch(Msg);
+  if err then
+    halt(1);
+end.

+ 44 - 0
tests/webtbs/uw6203.pp

@@ -0,0 +1,44 @@
+unit uw6203;
+
+{$mode delphi}
+
+interface
+
+const
+  CM_TEST = $B000 + 18;
+
+type
+  TMessage = packed record
+    Msg: Cardinal;
+    case Integer of
+      0: (
+        WParam: Longint;
+        LParam: Longint;
+        Result: Longint);
+      1: (
+        WParamLo: Word;
+        WParamHi: Word;
+        LParamLo: Word;
+        LParamHi: Word;
+        ResultLo: Word;
+        ResultHi: Word);
+  end;
+
+  TTest = class
+  private
+    procedure CMTest(var Msg: TMessage); message CM_TEST;
+  end;
+
+var
+  Err : boolean;
+  
+implementation
+
+procedure TTest.CMTest(var Msg: TMessage);
+begin
+  WriteLn('TTest.CMTest');
+  err:=false;
+end;
+
+end.
+