paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-19 14:19:31 +02:00
Code Issues Packages Projects Releases Wiki Activity

* fixed bug related to IMPLEMENTS keyword. The interface type was stored inside the interface defintion what was wrong! now it's set per TImplementedInterface$

Browse Source 
* merged IOffset and EntryOffset of TInterfaceEntry. The meaning of IOffset depends now on IType
    * to optimize: IOffset and FieldOffset of TImplementedInterface can be merged also! fpc still generate an interfacetable entry even for interfaces that aren't implemented in the current class (redirected by IMPLEMENTS keyword)

git-svn-id: trunk@6206 -
This commit is contained in:
ivost 2007-01-26 20:58:46 +00:00
parent 5f61271824
commit c0e9be49b8
5 changed files with 26 additions and 21 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

13
compiler/nobj.pas
View File

@ -521,7 +521,7 @@ implementation
ImplIntf.AddImplProc(implprocdef)
end
else
if ImplIntf.IntfDef.iitype = etStandard then
if ImplIntf.VtblImplIntf.itype = etStandard then
Message1(sym_e_no_matching_implementation_found,tprocdef(def).fullprocname(false));
end;
end;
@ -1221,7 +1221,10 @@ implementation
{ VTable }
current_asmdata.asmlists[al_globals].concat(Tai_const.Createname(intf_get_vtbl_name(AImplIntf.VtblImplIntf),0));
{ IOffset field }
current_asmdata.asmlists[al_globals].concat(Tai_const.Create_aint(AImplIntf.VtblImplIntf.ioffset));
if AImplIntf.VtblImplIntf.itype = etStandard then
current_asmdata.asmlists[al_globals].concat(Tai_const.Create_aint(AImplIntf.VtblImplIntf.ioffset))
else
current_asmdata.asmlists[al_globals].concat(Tai_const.Create_aint(AImplIntf.VtblImplIntf.fieldoffset));
{ IIDStr }
current_asmdata.getdatalabel(iidlabel);
rawdata.concat(cai_align.create(const_align(sizeof(aint))));
@ -1232,10 +1235,8 @@ implementation
else
rawdata.concat(Tai_string.Create(AImplIntf.IntfDef.iidstr^));
current_asmdata.asmlists[al_globals].concat(Tai_const.Create_sym(iidlabel));
{ EntryType }
current_asmdata.asmlists[al_globals].concat(Tai_const.Create_aint(aint(AImplIntf.IntfDef.iitype)));
{ EntryOffset }
current_asmdata.asmlists[al_globals].concat(Tai_const.Create_aint(aint(AImplIntf.IntfDef.iioffset)));
{ IType }
current_asmdata.asmlists[al_globals].concat(Tai_const.Create_aint(aint(AImplIntf.VtblImplIntf.itype)));
end;

4
compiler/pdecvar.pas
View File

@ -632,8 +632,8 @@ implementation
end;
if found then
begin
ImplIntf.IntfDef.iitype := etFieldValue;
ImplIntf.IntfDef.iioffset := tfieldvarsym(p.propaccesslist[palt_read].firstsym^.sym).fieldoffset;
ImplIntf.itype := etFieldValue;
ImplIntf.fieldoffset := tfieldvarsym(p.propaccesslist[palt_read].firstsym^.sym).fieldoffset;
end
else
Comment(V_Error,'Implements-property used on unimplemented interface');

13
compiler/symdef.pas
View File

@ -199,10 +199,14 @@ interface
TImplementedInterface = class
IntfDef : tobjectdef;
IntfDefDeref : tderef;
IType : tinterfaceentrytype;
IOffset : longint;
VtblImplIntf : TImplementedInterface;
VtblImplIntf : TImplementedInterface;
NameMappings : TFPHashList;
ProcDefs : TFPObjectList;
FieldOffset : longint;
// FieldOffset can be merged with IOffset. But then, fpc is not allowed to genrate a vmtentry.
// Right now, fpc generate an entry for all implemented interfaces (but it should just for etStandard ones)
constructor create(aintf: tobjectdef);
constructor create_deref(d:tderef);
destructor destroy; override;
@ -232,8 +236,6 @@ interface
objecttype : tobjecttyp;
iidguid : pguid;
iidstr : pshortstring;
iitype : tinterfaceentrytype;
iioffset : longint;
{ store implemented interfaces defs and name mappings }
ImplementedInterfaces : TFPObjectList;
constructor create(ot : tobjecttyp;const n : string;c : tobjectdef);
@ -3576,7 +3578,6 @@ implementation
else
ImplementedInterfaces:=nil;
writing_class_record_dbginfo:=false;
iitype := etStandard;
end;
@ -4027,6 +4028,8 @@ implementation
inherited create;
intfdef:=aintf;
ioffset:=-1;
itype:=etStandard;
fieldoffset:=-1;
NameMappings:=nil;
procdefs:=nil;
end;
@ -4038,6 +4041,8 @@ implementation
intfdef:=nil;
intfdefderef:=d;
ioffset:=-1;
itype:=etStandard;
fieldoffset:=-1;
NameMappings:=nil;
procdefs:=nil;
end;

14
rtl/inc/objpas.inc
View File

@ -173,7 +173,7 @@
i:=intftable^.EntryCount;
Res:=@intftable^.Entries[0];
while i>0 do begin
if Res^.EntryType = etStandard then
if Res^.IType = etStandard then
ppointer(@(pbyte(instance)[Res^.IOffset]))^:=
pointer(Res^.VTable);
inc(Res);
@ -604,9 +604,9 @@
Getter: function: IInterface of object;
begin
Pointer(Obj) := nil;
if Assigned(IEntry) then
if Assigned(IEntry) and Assigned(Instance) then
begin
case IEntry^.EntryType of
case IEntry^.IType of
etStandard:
begin
//writeln('Doing etStandard cast of ', TObject(Instance).classname(), ' with self = ', ptruint(Instance), ' and offset = ', IEntry^.IOffset);
@ -614,21 +614,21 @@
end;
etFieldValue:
begin
//writeln('Doing etFieldValue cast of ', TObject(Instance).classname(), ' with offset = ', IEntry^.EntryOffset);
Pointer(obj) := ppointer(Pointer(Instance)+IEntry^.EntryOffset)^;
//writeln('Doing etFieldValue cast of ', TObject(Instance).classname(), ' with offset = ', IEntry^.IOffset);
Pointer(obj) := ppointer(Pointer(Instance)+IEntry^.IOffset)^;
end;
etVirtualMethodResult:
begin
//writeln('Doing etVirtualMethodResult cast of ', TObject(Instance).classname());
TMethod(Getter).data := Instance;
TMethod(Getter).code := ppointer(ptrint(Instance) + IEntry^.EntryOffset)^;
TMethod(Getter).code := ppointer(ptrint(Instance) + IEntry^.IOffset)^;
Pointer(obj) := Pointer(Getter());
end;
etStaticMethodResult:
begin
//writeln('Doing etStaticMethodResult cast of ', TObject(Instance).classname());
TMethod(Getter).data := Instance;
TMethod(Getter).code := pointer(IEntry^.EntryOffset);
TMethod(Getter).code := pointer(IEntry^.IOffset);
Pointer(obj) := Pointer(Getter());
end;
end;

3
rtl/inc/objpash.inc
View File

@ -124,8 +124,7 @@
VTable : Pointer;
IOffset : PtrInt;
IIDStr : pshortstring; { never nil. Com: upper(GuidToString(IID^)) }
EntryType : tinterfaceentrytype;
EntryOffset : PtrInt;
IType : tinterfaceentrytype;
end;
pinterfacetable = ^tinterfacetable;