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

* fixed loading of addresses of virtual methods to methodpointers in delphi mode

Browse Source 
git-svn-id: trunk@1182 -
This commit is contained in:
florian 2005-09-25 10:58:17 +00:00
parent 6bc461dc61
commit be99f2a7fd
3 changed files with 57 additions and 2 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.gitattributes vendored
View File

@ -4978,6 +4978,7 @@ tests/tbs/tb0492.pp svneol=native#text/plain
tests/tbs/tb0493.pp svneol=native#text/plain tests/tbs/tb0493.pp svneol=native#text/plain
tests/tbs/tb0494.pp -text tests/tbs/tb0494.pp -text
tests/tbs/tb0495.pp svneol=native#text/plain tests/tbs/tb0495.pp svneol=native#text/plain
tests/tbs/tb0496.pp svneol=native#text/plain
tests/tbs/ub0060.pp svneol=native#text/plain tests/tbs/ub0060.pp svneol=native#text/plain
tests/tbs/ub0069.pp svneol=native#text/plain tests/tbs/ub0069.pp svneol=native#text/plain
tests/tbs/ub0119.pp svneol=native#text/plain tests/tbs/ub0119.pp svneol=native#text/plain

18
compiler/ncnv.pas
View File

@ -1382,7 +1382,7 @@ implementation
var var
htype : ttype; htype : ttype;
hp : tnode; hp,hp2 : tnode;
currprocdef : tabstractprocdef; currprocdef : tabstractprocdef;
aprocdef : tprocdef; aprocdef : tprocdef;
eq : tequaltype; eq : tequaltype;
@ -1518,7 +1518,23 @@ implementation
if (tcallnode(left).symtableprocentry.owner.symtabletype=objectsymtable) then if (tcallnode(left).symtableprocentry.owner.symtabletype=objectsymtable) then
begin begin
if assigned(tcallnode(left).methodpointer) then 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) tloadnode(hp).set_mp(tcallnode(left).get_load_methodpointer)
end
else else
tloadnode(hp).set_mp(load_self_node); tloadnode(hp).set_mp(load_self_node);
end; end;

38
tests/tbs/tb0496.pp Normal file
View File

@ -0,0 +1,38 @@
{$mode delphi}
type
tmyclass = class
procedure m1;virtual;
procedure m2;virtual;
end;
tm1 = procedure of object;
var
res : longint;
procedure tmyclass.m1;
begin
res:=1;
end;
procedure p2(m1 : tm1);
begin
m1;
end;
procedure tmyclass.m2;
begin
p2(m1);
end;
var
myclass : tmyclass;
begin
res:=$deadbeef;
myclass:=tmyclass.create;
myclass.m2;
myclass.free;
if res<>1 then
halt(1);
writeln('ok');
end.