--- Merging r14005 into '.':

U    utils/fpdoc/dw_html.pp
U    rtl/inc/objpash.inc
U    rtl/inc/objpas.inc
U    rtl/objpas/classes/parser.inc
A    tests/test/tobject5.pp
U    compiler/nobj.pas
U    packages/fcl-passrc/src/pparser.pp
--- Merging r14013 into '.':
U    rtl/objpas/classes/stringl.inc
U    rtl/objpas/classes/bits.inc
U    rtl/objpas/classes/classesh.inc
--- Merging r14869 into '.':
G    rtl/inc/objpash.inc
G    rtl/inc/objpas.inc
U    tests/test/tobject5.pp
A    tests/webtbs/tw15693.pp

# revisions: 14005,14013,14869
------------------------------------------------------------------------
r14005 | paul | 2009-11-01 17:22:47 +0100 (Sun, 01 Nov 2009) | 2 lines
Changed paths:
   M /trunk/compiler/nobj.pas
   M /trunk/packages/fcl-passrc/src/pparser.pp
   M /trunk/rtl/inc/objpas.inc
   M /trunk/rtl/inc/objpash.inc
   M /trunk/rtl/objpas/classes/parser.inc
   A /trunk/tests/test/tobject5.pp
   M /trunk/utils/fpdoc/dw_html.pp

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)
------------------------------------------------------------------------
------------------------------------------------------------------------
r14013 | paul | 2009-11-03 03:01:06 +0100 (Tue, 03 Nov 2009) | 1 line
Changed paths:
   M /trunk/rtl/objpas/classes/bits.inc
   M /trunk/rtl/objpas/classes/classesh.inc
   M /trunk/rtl/objpas/classes/stringl.inc

rtl: override TObject.Equals for TBits and TStrings classes
------------------------------------------------------------------------
------------------------------------------------------------------------
r14869 | jonas | 2010-02-06 18:53:49 +0100 (Sat, 06 Feb 2010) | 4 lines
Changed paths:
   M /trunk/rtl/inc/objpas.inc
   M /trunk/rtl/inc/objpash.inc
   M /trunk/tests/test/tobject5.pp
   A /trunk/tests/webtbs/tw15693.pp

  * tobject.unitname and tobject.tostring have to return an ansistring instead
    of a shortstring (mantis #15693)
  * changed tobject5 so it checks whether the return values are correct

------------------------------------------------------------------------

git-svn-id: branches/fixes_2_4@15282 -

.gitattributes

@@ -8425,6 +8425,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
@@ -9494,6 +9495,7 @@ tests/webtbs/tw15453a.pp svneol=native#text/plain
 tests/webtbs/tw15467.pp svneol=native#text/pascal
 tests/webtbs/tw1567.pp svneol=native#text/plain
 tests/webtbs/tw15690.pp svneol=native#text/plain
+tests/webtbs/tw15693.pp svneol=native#text/plain
 tests/webtbs/tw15727a.pp svneol=native#text/plain
 tests/webtbs/tw15728.pp svneol=native#text/plain
 tests/webtbs/tw1573.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

@@ -1112,18 +1112,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

@@ -718,6 +718,47 @@
           getinterfacetable:=PVmt(Self)^.vIntfTable;
         end;
 
+      class function TObject.UnitName : ansistring;
+        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: ansistring;
+        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 : ansistring;
+          function Equals(Obj: TObject) : boolean;virtual;
+          function GetHashCode: PtrInt;virtual;
+          function ToString: ansistring;virtual;
        end;
 
        IUnknown = interface

rtl/objpas/classes/bits.inc

@@ -232,6 +232,14 @@ begin
       FBits^[loop] := FBits^[loop] xor bitset.FBits^[loop];
 end;
 
+function TBits.Equals(Obj : TObject): Boolean;
+begin
+  if Obj is TBits then
+    Result := Equals(TBits(Obj))
+  else
+    Result := inherited Equals(Obj);
+end;
+
 function TBits.equals(bitset : TBits) : Boolean;
 var
    n : longint;

rtl/objpas/classes/classesh.inc

@@ -360,7 +360,8 @@ type
       procedure NotBits(BitSet : TBits);
       function  Get(Bit : longint) : boolean;
       procedure Grow(NBit : longint);
-      function  Equals(BitSet : TBits) : Boolean;
+      function  Equals(Obj : TObject): Boolean; override; overload;
+      function  Equals(BitSet : TBits) : Boolean; overload;
       procedure SetIndex(Index : longint);
       function  FindFirstBit(State : boolean) : longint;
       function  FindNextBit : longint;
@@ -601,7 +602,8 @@ type
     procedure Clear; virtual; abstract;
     procedure Delete(Index: Integer); virtual; abstract;
     procedure EndUpdate;
-    function Equals(TheStrings: TStrings): Boolean;
+    function Equals(Obj: TObject): Boolean; override; overload;
+    function Equals(TheStrings: TStrings): Boolean; overload;
     procedure Exchange(Index1, Index2: Integer); virtual;
     function GetEnumerator: TStringsEnumerator;
     function GetText: PChar; virtual;

rtl/objpas/classes/parser.inc

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

rtl/objpas/classes/stringl.inc

@@ -653,6 +653,17 @@ end;
 
 
 
+Function TStrings.Equals(Obj: TObject): Boolean;
+
+begin
+  if Obj is TStrings then
+    Result := Equals(TStrings(Obj))
+  else
+    Result := inherited Equals(Obj);
+end;
+
+
+
 Function TStrings.Equals(TheStrings: TStrings): Boolean;
 
 Var Runner,Nr : Longint;

tests/test/tobject5.pp

@@ -0,0 +1,18 @@
+program tobject1;
+
+{$apptype console}
+{$mode objfpc}{$H+}
+var
+  Obj: TObject;
+begin
+  Obj := TObject.Create;
+  if not Obj.Equals(Obj) then
+    halt(1); // true
+  WriteLn(Obj.GetHashCode); // PtrInt(Obj)
+  if Obj.UnitName<>'System' then
+    halt(2); // System
+  if Obj.ToString<>'TObject' then
+    halt(3); // TObject
+  Obj.Free;
+end.
+

tests/webtbs/tw15693.pp

@@ -0,0 +1,17 @@
+{ %norun }
+
+{$mode objfpc}
+{$h+}
+
+type
+  TMyClass = class
+    function ToString: String; override;
+  end;
+
+function TMyClass.ToString: String;
+begin
+  Result:=inherited;
+end;
+
+begin
+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;
 
@@ -796,12 +796,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;