* fixed loading the address of class methods (mantis #9139)

git-svn-id: trunk@7789 -

.gitattributes

@@ -8313,6 +8313,8 @@ tests/webtbs/tw9107.pp svneol=native#text/plain
 tests/webtbs/tw9108.pp svneol=native#text/plain
 tests/webtbs/tw9113.pp svneol=native#text/plain
 tests/webtbs/tw9128.pp svneol=native#text/plain
+tests/webtbs/tw9139.pp svneol=native#text/plain
+tests/webtbs/tw9139a.pp svneol=native#text/plain
 tests/webtbs/ub1873.pp svneol=native#text/plain
 tests/webtbs/ub1883.pp svneol=native#text/plain
 tests/webtbs/uw0555.pp svneol=native#text/plain

compiler/ncgld.pas

@@ -413,7 +413,7 @@ implementation
                       tg.GetTemp(current_asmdata.CurrAsmList,2*sizeof(aint),tt_normal,location.reference);
                       secondpass(left);
 
-                      { load class instance address }
+                      { load class instance/classrefdef address }
                       if left.location.loc=LOC_CONSTANT then
                         location_force_reg(current_asmdata.CurrAsmList,left.location,OS_ADDR,false);
                       case left.location.loc of
@@ -429,7 +429,7 @@ implementation
                          LOC_REFERENCE:
                            begin
                               hregister:=cg.getaddressregister(current_asmdata.CurrAsmList);
-                              if is_class_or_interface(left.resultdef) then
+                              if not is_object(left.resultdef) then
                                 cg.a_load_ref_reg(current_asmdata.CurrAsmList,OS_ADDR,OS_ADDR,left.location.reference,hregister)
                               else
                                 cg.a_loadaddr_ref_reg(current_asmdata.CurrAsmList,left.location.reference,hregister);
@@ -439,7 +439,7 @@ implementation
                            internalerror(200610311);
                       end;
 
-                      { store the class instance address }
+                      { store the class instance or classredef address }
                       href:=location.reference;
                       inc(href.offset,sizeof(aint));
                       cg.a_load_reg_ref(current_asmdata.CurrAsmList,OS_ADDR,OS_ADDR,hregister,href);
@@ -448,10 +448,14 @@ implementation
                       if (po_virtualmethod in procdef.procoptions) and
                          not(nf_inherited in flags) then
                         begin
-                          { load vmt pointer }
-                          reference_reset_base(href,hregister,0);
-                          hregister:=cg.getaddressregister(current_asmdata.CurrAsmList);
-                          cg.a_load_ref_reg(current_asmdata.CurrAsmList,OS_ADDR,OS_ADDR,href,hregister);
+                          { a classrefdef already points to the VMT }
+                          if (left.resultdef.typ<>classrefdef) then
+                            begin
+                              { load vmt pointer }
+                              reference_reset_base(href,hregister,0);
+                              hregister:=cg.getaddressregister(current_asmdata.CurrAsmList);
+                              cg.a_load_ref_reg(current_asmdata.CurrAsmList,OS_ADDR,OS_ADDR,href,hregister);
+                            end;
                           { load method address }
                           reference_reset_base(href,hregister,procdef._class.vmtmethodoffset(procdef.extnumber));
                           hregister:=cg.getaddressregister(current_asmdata.CurrAsmList);

tests/webtbs/tw9139.pp

@@ -0,0 +1,72 @@
+{$mode objfpc}{$H+}
+{.$define second_test}
+
+type
+  TTestClass = class of TTestBase;
+
+  TTestBase = class(TObject)
+  public
+    class function ClassMetadataStr: string;
+    class function InternalMetadataStr: string; virtual;
+  end;
+
+  TTestImpl = class(TTestBase)
+  public
+    class function InternalMetadataStr: string; override;
+  end;
+
+class function TTestBase.ClassMetadataStr: string;
+var
+  VMetadataMethod, VParentMetadataMethod: function: string of object;
+{$ifdef second_test}
+  VClass: TTestClass;
+{$endif}
+begin
+  if Self <> TTestBase then
+  begin
+    writeln('pass 1');
+    VMetadataMethod := @InternalMetadataStr;
+    writeln('pass 2');
+{$ifndef second_test}
+    VParentMetadataMethod := @TTestClass(ClassParent).InternalMetadataStr;
+{$else}
+    VClass := TTestClass(ClassParent);
+    writeln('pass 2.1');
+    VParentMetadataMethod := @VClass.InternalMetadataStr;
+{$endif}
+    writeln('pass 3');
+    if TMethod(VMetadataMethod).Code <> TMethod(VParentMetadataMethod).Code then
+      begin
+        Result := VParentMetadataMethod();
+        writeln('result: ',result);
+        if Result<>'parent meth' then
+          halt(1);
+      end
+    else
+      halt(2);
+    writeln('pass 4');
+  end else
+    Result := 'base result';
+end;
+
+class function TTestBase.InternalMetadataStr: string;
+begin
+  Result := 'parent meth';
+end;
+
+class function TTestImpl.InternalMetadataStr: string;
+begin
+  Result := 'some stuff';
+end;
+
+var
+  VTestClass: TTestClass;
+begin
+  VTestClass := TTestBase;
+  writeln('TTestBase result:');
+  writeln(VTestClass.ClassMetadataStr);
+  writeln;
+  VTestClass := TTestImpl;
+  writeln('TTestImpl result:');
+  writeln(VTestClass.ClassMetadataStr);
+end.

tests/webtbs/tw9139a.pp

@@ -0,0 +1,72 @@
+{$mode objfpc}{$H+}
+{$define second_test}
+
+type
+  TTestClass = class of TTestBase;
+
+  TTestBase = class(TObject)
+  public
+    class function ClassMetadataStr: string;
+    class function InternalMetadataStr: string; virtual;
+  end;
+
+  TTestImpl = class(TTestBase)
+  public
+    class function InternalMetadataStr: string; override;
+  end;
+
+class function TTestBase.ClassMetadataStr: string;
+var
+  VMetadataMethod, VParentMetadataMethod: function: string of object;
+{$ifdef second_test}
+  VClass: TTestClass;
+{$endif}
+begin
+  if Self <> TTestBase then
+  begin
+    writeln('pass 1');
+    VMetadataMethod := @InternalMetadataStr;
+    writeln('pass 2');
+{$ifndef second_test}
+    VParentMetadataMethod := @TTestClass(ClassParent).InternalMetadataStr;
+{$else}
+    VClass := TTestClass(ClassParent);
+    writeln('pass 2.1');
+    VParentMetadataMethod := @VClass.InternalMetadataStr;
+{$endif}
+    writeln('pass 3');
+    if TMethod(VMetadataMethod).Code <> TMethod(VParentMetadataMethod).Code then
+      begin
+        Result := VParentMetadataMethod();
+        writeln('result: ',result);
+        if Result<>'parent meth' then
+          halt(1);
+      end
+    else
+      halt(2);
+    writeln('pass 4');
+  end else
+    Result := 'base result';
+end;
+
+class function TTestBase.InternalMetadataStr: string;
+begin
+  Result := 'parent meth';
+end;
+
+class function TTestImpl.InternalMetadataStr: string;
+begin
+  Result := 'some stuff';
+end;
+
+var
+  VTestClass: TTestClass;
+begin
+  VTestClass := TTestBase;
+  writeln('TTestBase result:');
+  writeln(VTestClass.ClassMetadataStr);
+  writeln;
+  VTestClass := TTestImpl;
+  writeln('TTestImpl result:');
+  writeln(VTestClass.ClassMetadataStr);
+end.