paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-09-03 18:10:17 +02:00
Code Issues Packages Projects Releases Wiki Activity

* cleaner fix for tb0496 (r1185)

Browse Source 
git-svn-id: trunk@1196 -
This commit is contained in:
peter 2005-09-25 19:23:37 +00:00
parent 0f10de3d1a
commit 2f0fdd1847
6 changed files with 85 additions and 95 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

16
compiler/ncal.pas
View File

@ -1906,22 +1906,6 @@ type
{ bind parasyms to the callparanodes and insert hidden parameters }
bind_parasym;
{ methodpointer needs to be a pointer to the VMT for virtual calls.
Note: We need to keep the methodpointer in the callnode for TP
procvar support, because this calln still maybe converted to a loadn,
see tw3499 }
if (po_virtualmethod in procdefinition.procoptions) then
begin
if not assigned(methodpointer) then
internalerror(200305063);
if (methodpointer.nodetype<>typen) and
(methodpointer.resulttype.def.deftype<>classrefdef) then
begin
methodpointer:=cloadvmtaddrnode.create(methodpointer);
resulttypepass(methodpointer);
end;
end;
{ insert type conversions for parameters }
if assigned(left) then
tcallparanode(left).insert_typeconv(true);

21
compiler/ncgcal.pas
View File

@ -855,22 +855,27 @@ implementation
assigned(methodpointer) and
(methodpointer.nodetype<>typen) then
begin
secondpass(methodpointer);
location_force_reg(exprasmlist,methodpointer.location,OS_ADDR,false);
{ virtual methods require an index }
if tprocdef(procdefinition).extnumber=$ffff then
internalerror(200304021);
{ VMT should already be loaded in a register }
if methodpointer.location.register=NR_NO then
internalerror(200304022);
secondpass(methodpointer);
{ Load VMT from self }
if methodpointer.resulttype.def.deftype=objectdef then
gen_load_vmt_register(exprasmlist,tobjectdef(methodpointer.resulttype.def),methodpointer.location,vmtreg)
else
begin
{ Load VMT value in register }
location_force_reg(exprasmlist,methodpointer.location,OS_ADDR,false);
vmtreg:=methodpointer.location.register;
end;
{ test validity of VMT }
if not(is_interface(tprocdef(procdefinition)._class)) and
not(is_cppclass(tprocdef(procdefinition)._class)) then
cg.g_maybe_testvmt(exprasmlist,methodpointer.location.register,tprocdef(procdefinition)._class);
cg.g_maybe_testvmt(exprasmlist,vmtreg,tprocdef(procdefinition)._class);
vmtreg:=methodpointer.location.register;
pvreg:=cg.getintregister(exprasmlist,OS_ADDR);
reference_reset_base(href,vmtreg,
tprocdef(procdefinition)._class.vmtmethodoffset(tprocdef(procdefinition).extnumber));

65
compiler/ncgmem.pas
View File

@ -98,60 +98,19 @@ implementation
begin
location_reset(location,LOC_REGISTER,OS_ADDR);
if (left.nodetype<>typen) then
begin
{ left contains self, load vmt from self }
secondpass(left);
if is_object(left.resulttype.def) then
begin
case left.location.loc of
LOC_CREFERENCE,
LOC_REFERENCE:
begin
reference_reset_base(href,cg.getaddressregister(exprasmlist),tobjectdef(left.resulttype.def).vmt_offset);
cg.a_loadaddr_ref_reg(exprasmlist,left.location.reference,href.base);
end;
else
internalerror(200305056);
end;
end
else
begin
case left.location.loc of
LOC_REGISTER:
begin
{$ifdef cpu_uses_separate_address_registers}
if getregtype(left.location.register)<>R_ADDRESSREGISTER then
begin
reference_reset_base(href,cg.getaddressregister(exprasmlist),tobjectdef(left.resulttype.def).vmt_offset);
cg.a_load_reg_reg(exprasmlist,OS_ADDR,OS_ADDR,left.location.register,href.base);
end
else
{$endif}
reference_reset_base(href,left.location.register,tobjectdef(left.resulttype.def).vmt_offset);
end;
LOC_CREGISTER,
LOC_CREFERENCE,
LOC_REFERENCE:
begin
reference_reset_base(href,cg.getaddressregister(exprasmlist),tobjectdef(left.resulttype.def).vmt_offset);
cg.a_load_loc_reg(exprasmlist,OS_ADDR,left.location,href.base);
end;
else
internalerror(200305057);
end;
end;
location.register:=cg.getaddressregister(exprasmlist);
cg.g_maybe_testself(exprasmlist,href.base);
cg.a_load_ref_reg(exprasmlist,OS_ADDR,OS_ADDR,href,location.register);
end
if (left.nodetype=typen) then
begin
reference_reset_symbol(href,
objectlibrary.newasmsymbol(tobjectdef(tclassrefdef(resulttype.def).pointertype.def).vmt_mangledname,AB_EXTERNAL,AT_DATA),0);
location.register:=cg.getaddressregister(exprasmlist);
cg.a_loadaddr_ref_reg(exprasmlist,href,location.register);
end
else
begin
reference_reset_symbol(href,
objectlibrary.newasmsymbol(tobjectdef(tclassrefdef(resulttype.def).pointertype.def).vmt_mangledname,AB_EXTERNAL,AT_DATA),0);
location.register:=cg.getaddressregister(exprasmlist);
cg.a_loadaddr_ref_reg(exprasmlist,href,location.register);
end;
begin
{ left contains self, load vmt from self }
secondpass(left);
gen_load_vmt_register(exprasmlist,tobjectdef(left.resulttype.def),left.location,location.register);
end;
end;

50
compiler/ncgutil.pas
View File

@ -71,6 +71,7 @@ interface
procedure gen_external_stub(list:taasmoutput;pd:tprocdef;const externalname:string);
procedure gen_intf_wrappers(list:taasmoutput;st:tsymtable);
procedure gen_load_vmt_register(list:taasmoutput;objdef:tobjectdef;selfloc:tlocation;var vmtreg:tregister);
{#
Allocate the buffers for exception management and setjmp environment.
@ -2390,4 +2391,53 @@ implementation
end;
end;
procedure gen_load_vmt_register(list:taasmoutput;objdef:tobjectdef;selfloc:tlocation;var vmtreg:tregister);
var
href : treference;
begin
if is_object(objdef) then
begin
case selfloc.loc of
LOC_CREFERENCE,
LOC_REFERENCE:
begin
reference_reset_base(href,cg.getaddressregister(list),objdef.vmt_offset);
cg.a_loadaddr_ref_reg(list,selfloc.reference,href.base);
end;
else
internalerror(200305056);
end;
end
else
begin
case selfloc.loc of
LOC_REGISTER:
begin
{$ifdef cpu_uses_separate_address_registers}
if getregtype(left.location.register)<>R_ADDRESSREGISTER then
begin
reference_reset_base(href,cg.getaddressregister(list),objdef.vmt_offset);
cg.a_load_reg_reg(list,OS_ADDR,OS_ADDR,selfloc.register,href.base);
end
else
{$endif cpu_uses_separate_address_registers}
reference_reset_base(href,selfloc.register,objdef.vmt_offset);
end;
LOC_CREGISTER,
LOC_CREFERENCE,
LOC_REFERENCE:
begin
reference_reset_base(href,cg.getaddressregister(list),objdef.vmt_offset);
cg.a_load_loc_reg(list,OS_ADDR,selfloc,href.base);
end;
else
internalerror(200305057);
end;
end;
vmtreg:=cg.getaddressregister(list);
cg.g_maybe_testself(list,href.base);
cg.a_load_ref_reg(list,OS_ADDR,OS_ADDR,href,vmtreg);
end;
end.

18
compiler/ncnv.pas
View File

@ -1518,23 +1518,7 @@ implementation
if (tcallnode(left).symtableprocentry.owner.symtabletype=objectsymtable) then
begin
if assigned(tcallnode(left).methodpointer) then
begin
{ kick the loadvmtaddrnode we added in ncal.pas around line 1920?
if you mess around here, check tbs/tb0496.pp (FK)
}
if (po_virtualmethod in tcallnode(left).procdefinition.procoptions) and
(tcallnode(left).methodpointer.nodetype=loadvmtaddrn) and
assigned(tloadvmtaddrnode(tcallnode(left).methodpointer).left) and
(tloadvmtaddrnode(tcallnode(left).methodpointer).left.nodetype<>typen) and
(tloadvmtaddrnode(tcallnode(left).methodpointer).left.resulttype.def.deftype<>classrefdef) then
begin
hp2:=tcallnode(left).methodpointer;
tcallnode(left).methodpointer:=tloadvmtaddrnode(tcallnode(left).methodpointer).left;
tloadvmtaddrnode(hp2).left:=nil;
hp2.free;
end;
tloadnode(hp).set_mp(tcallnode(left).get_load_methodpointer)
end
tloadnode(hp).set_mp(tcallnode(left).get_load_methodpointer)
else
tloadnode(hp).set_mp(load_self_node);
end;

10
tests/webtbs/tw3499.pp
View File

@ -3,10 +3,13 @@
{ e-mail: svg@deds.nl }
program test;
{$mode delphi}
{$ifdef fpc}{$mode delphi}{$endif}
uses SysUtils;
var
err : boolean;
type
TProcedure = procedure of object;
Class1 = class
@ -27,13 +30,18 @@ end;
procedure Class2.d();
begin
writeLn('procedure called');
err:=false;
end;
var
c: Class1;
e: Class2;
begin
err:=true;
c := Class1.create();
e := Class2.create();
c.p(e.d);
c.proc;
if err then
halt(1);
end.