mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-12-05 11:23:07 +01:00
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 -
This commit is contained in:
paul
parent
dfdfec0201
commit
dfef902c53
1
.gitattributes
vendored
1
.gitattributes
vendored
@ -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
|
||||
|
||||
@ -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;
|
||||
|
||||
|
||||
@ -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);
|
||||
|
||||
|
||||
@ -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
|
||||
****************************************************************************}
|
||||
|
||||
@ -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
|
||||
|
||||
@ -261,7 +261,7 @@ begin
|
||||
else break;
|
||||
end;
|
||||
if ascii then
|
||||
fToken:=toString
|
||||
fToken:=Classes.toString
|
||||
else
|
||||
fToken:=toWString;
|
||||
fLastTokenStr:=fLastTokenWStr;
|
||||
|
||||
15
tests/test/tobject5.pp
Normal file
15
tests/test/tobject5.pp
Normal file
@ -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.
|
||||
|
||||
@ -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;
|
||||
|
||||
Loading…
Reference in New Issue
Block a user