rtl: introduce new TObject methods: UnitName, GetHashCode, Equals, ToString added for compatibility with delphi 2009.

 + changes in compiler, utils, packages to resolve identifier conflicts with the new TObject methods (like changing of UnitName arguments to AUnitName, adding Classes. before the toString, etc). (issue #0014931)

git-svn-id: trunk@14005 -

.gitattributes

@@ -8319,6 +8319,7 @@ tests/test/tobject1.pp svneol=native#text/plain
 tests/test/tobject2.pp svneol=native#text/plain
 tests/test/tobject3.pp svneol=native#text/plain
 tests/test/tobject4.pp svneol=native#text/plain
+tests/test/tobject5.pp svneol=native#text/pascal
 tests/test/toperator1.pp svneol=native#text/plain
 tests/test/toperator2.pp svneol=native#text/plain
 tests/test/toperator3.pp svneol=native#text/plain

compiler/nobj.pas

@@ -422,7 +422,7 @@ implementation
         timpls    = array[0..1000] of longint;
         pimpls    = ^timpls;
       var
-        equals: pequals;
+        aequals: pequals;
         compats: pcompintfs;
         impls: pimpls;
         ImplIntfCount,
@@ -436,10 +436,10 @@ implementation
         if ImplIntfCount>=High(tequals) then
           Internalerror(200006135);
         getmem(compats,sizeof(tcompintfentry)*ImplIntfCount);
-        getmem(equals,sizeof(longint)*ImplIntfCount);
+        getmem(aequals,sizeof(longint)*ImplIntfCount);
         getmem(impls,sizeof(longint)*ImplIntfCount);
         filldword(compats^,(sizeof(tcompintfentry) div sizeof(dword))*ImplIntfCount,dword(-1));
-        filldword(equals^,ImplIntfCount,dword(-1));
+        filldword(aequals^,ImplIntfCount,dword(-1));
         filldword(impls^,ImplIntfCount,dword(-1));
         { ismergepossible is a containing relation
           meaning of ismergepossible(a,b,w) =
@@ -458,8 +458,8 @@ implementation
                 if cij and cji then { i equal j }
                   begin
                     { get minimum index of equal }
-                    if equals^[j]=-1 then
-                      equals^[j]:=i;
+                    if aequals^[j]=-1 then
+                      aequals^[j]:=i;
                   end
                 else if cij then
                   begin
@@ -496,8 +496,8 @@ implementation
             begin
               if compats^[impls^[i]].compintf<>-1 then
                 impls^[i]:=compats^[impls^[i]].compintf
-              else if equals^[impls^[i]]<>-1 then
-                impls^[i]:=equals^[impls^[i]]
+              else if aequals^[impls^[i]]<>-1 then
+                impls^[i]:=aequals^[impls^[i]]
               else
                 inc(k);
             end;
@@ -509,7 +509,7 @@ implementation
             ImplIntfI.VtblImplIntf:=TImplementedInterface(_class.ImplementedInterfaces[impls^[i]]);
           end;
         freemem(compats);
-        freemem(equals);
+        freemem(aequals);
         freemem(impls);
       end;
 

packages/fcl-passrc/src/pparser.pp

@@ -872,18 +872,18 @@ end;
 // Starts after the "uses" token
 procedure TPasParser.ParseUsesList(ASection: TPasSection);
 var
-  UnitName: String;
+  AUnitName: String;
   Element: TPasElement;
 begin
   while True do
   begin
-    UnitName := ExpectIdentifier;
+    AUnitName := ExpectIdentifier;
 
-    Element := Engine.FindModule(UnitName);
+    Element := Engine.FindModule(AUnitName);
     if Assigned(Element) then
       Element.AddRef
     else
-      Element := TPasType(CreateElement(TPasUnresolvedTypeRef, UnitName,
+      Element := TPasType(CreateElement(TPasUnresolvedTypeRef, AUnitName,
         ASection));
     ASection.UsesList.Add(Element);
 

rtl/inc/objpas.inc

@@ -711,6 +711,47 @@
           getinterfacetable:=PVmt(Self)^.vIntfTable;
         end;
 
+      class function TObject.UnitName : string;
+        type
+          // from the typinfo unit
+          TClassTypeInfo = {$ifndef FPC_REQUIRES_PROPER_ALIGNMENT}packed{$endif}record
+            ClassType: TClass;
+            ParentInfo: Pointer;
+            PropCount: SmallInt;
+            UnitName: ShortString;
+          end;
+          PClassTypeInfo = ^TClassTypeInfo;
+        var
+          classtypeinfo: PClassTypeInfo;
+        begin
+          classtypeinfo:=ClassInfo;
+          if Assigned(classtypeinfo) then
+          begin
+            // offset PTypeInfo by Length(Name) + 2 (ShortString length byte + SizeOf(Kind))
+            inc(Pointer(classtypeinfo), PByte(Pointer(classtypeinfo)+1)^ + 2);
+            {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
+            classtypeinfo:=align(classtypeinfo,sizeof(classtypeinfo));
+            {$endif}
+            result:=classtypeinfo^.UnitName;
+          end
+          else
+            result:='';
+        end;
+
+      function TObject.Equals(Obj: TObject) : boolean;
+        begin
+          result:=Obj=Self;
+        end;
+
+      function TObject.GetHashCode: PtrInt;
+        begin
+          result:=PtrInt(Self);
+        end;
+
+      function TObject.ToString: string;
+        begin
+          result:=ClassName;
+        end;
 {****************************************************************************
                                TINTERFACEDOBJECT
 ****************************************************************************}

rtl/inc/objpash.inc

@@ -56,6 +56,9 @@
        vmtDefaultHandlerStr    = vmtMethodStart+sizeof(pointer)*7;
        vmtDispatch             = vmtMethodStart+sizeof(pointer)*8;
        vmtDispatchStr          = vmtMethodStart+sizeof(pointer)*9;
+       vmtEquals               = vmtMethodStart+sizeof(pointer)*10;
+       vmtGetHashCode          = vmtMethodStart+sizeof(pointer)*11;
+       vmtToString             = vmtMethodStart+sizeof(pointer)*12;
 
        { IInterface }
        S_OK          = 0;
@@ -117,6 +120,9 @@
          vDefaultHandlerStr: Pointer;
          vDispatch: Pointer;
          vDispatchStr: Pointer;
+         vEquals: Pointer;
+         vGetHashCode: Pointer;
+         vToString: Pointer;
        end;
 
        PGuid = ^TGuid;
@@ -219,6 +225,12 @@
           class function GetInterfaceEntry(const iid : tguid) : pinterfaceentry;
           class function GetInterfaceEntryByStr(const iidstr : shortstring) : pinterfaceentry;
           class function GetInterfaceTable : pinterfacetable;
+
+          { new since Delphi 2009 }
+          class function UnitName : string;
+          function Equals(Obj: TObject) : boolean;virtual;
+          function GetHashCode: PtrInt;virtual;
+          function ToString: string;virtual;
        end;
 
        IUnknown = interface

rtl/objpas/classes/parser.inc

@@ -261,7 +261,7 @@ begin
       else break;
     end;
   if ascii then
-    fToken:=toString
+    fToken:=Classes.toString
   else
     fToken:=toWString;
   fLastTokenStr:=fLastTokenWStr;

tests/test/tobject5.pp

@@ -0,0 +1,15 @@
+program tobject1;
+
+{$apptype console}
+{$mode objfpc}{$H+}
+var
+  Obj: TObject;
+begin
+  Obj := TObject.Create;
+  WriteLn(Obj.Equals(Obj)); // true
+  WriteLn(Obj.GetHashCode); // PtrInt(Obj)
+  WriteLn(Obj.UnitName); // System
+  WriteLn(Obj.ToString); // TObject
+  Obj.Free;
+end.
+

utils/fpdoc/dw_html.pp

@@ -113,7 +113,7 @@ type
 
     Procedure CreateAllocator; virtual;
     function ResolveLinkID(const Name: String): DOMString;
-    function ResolveLinkIDInUnit(const Name,UnitName: String): DOMString;
+    function ResolveLinkIDInUnit(const Name,AUnitName: String): DOMString;
     function ResolveLinkWithinPackage(AElement: TPasElement;
       ASubpageIndex: Integer): String;
 
@@ -794,12 +794,12 @@ end;
   - AppendHyperlink (for unresolved parse tree element links)
 }
 
-function THTMLWriter.ResolveLinkIDInUnit(const Name,UnitName: String): DOMString;
+function THTMLWriter.ResolveLinkIDInUnit(const Name,AUnitName: String): DOMString;
 
 begin
   Result:=ResolveLinkID(Name);
-  If (Result='') and (UnitName<>'')  then
-    Result:=ResolveLinkID(UnitName+'.'+Name);
+  If (Result='') and (AUnitName<>'')  then
+    Result:=ResolveLinkID(AUnitName+'.'+Name);
 end;
 
 function THTMLWriter.ResolveLinkID(const Name: String): DOMString;