* apply patch by Blaise.ru: avoid internal error when assigning class methods, accessed via a class reference type, to incompatible procvars

+ added tests
This commit is contained in:
Sven/Sarah Barth 2022-01-06 21:54:46 +01:00
parent a8cf67d73b
commit 6e7a82440e
6 changed files with 90 additions and 2 deletions

View File

@ -2494,6 +2494,7 @@ implementation
aprocdef : tprocdef;
eq : tequaltype;
cdoptions : tcompare_defs_options;
selfnode : tnode;
newblock: tblocknode;
newstatement: tstatementnode;
tempnode: ttempcreatenode;
@ -2657,8 +2658,14 @@ implementation
tprocdef(currprocdef),tcallnode(left).symtableproc);
if (tcallnode(left).symtableprocentry.owner.symtabletype=ObjectSymtable) then
begin
if assigned(tcallnode(left).methodpointer) then
tloadnode(hp).set_mp(tcallnode(left).methodpointer.getcopy)
selfnode:=tcallnode(left).methodpointer;
if assigned(selfnode) then
begin
{ in case the nodetype is a typen, avoid the internal error
in set_mp and instead let the code error out normally }
if selfnode.nodetype<>typen then
tloadnode(hp).set_mp(selfnode.getcopy)
end
else
tloadnode(hp).set_mp(load_self_node);
end;

17
tests/test/tprocvar11.pp Normal file
View File

@ -0,0 +1,17 @@
{ %FAIL }
program tprocvar11;
{$mode delphi}
type C = class
class procedure NonStatic;
end;
class procedure C.NonStatic; begin end;
type CC = class of C;
var IncompatWNonStatic: procedure;
begin
IncompatWNonStatic := CC.NonStatic;
end.

17
tests/test/tprocvar12.pp Normal file
View File

@ -0,0 +1,17 @@
{ %FAIL }
program tprocvar12;
{$mode delphi}
type C = class
class procedure Static; static;
end;
class procedure C.Static; begin end;
type CC = class of C;
var IncompatWStatic: procedure of object;
begin
IncompatWStatic := CC.Static;
end.

15
tests/test/tprocvar13.pp Normal file
View File

@ -0,0 +1,15 @@
{ %FAIL }
program tprocvar13;
{$mode delphi}
type O = object
class procedure Static; static;
end;
class procedure O.Static; begin end;
var IncompatWStatic: procedure of object;
begin
IncompatWStatic := O.Static;
end.

16
tests/test/tprocvar14.pp Normal file
View File

@ -0,0 +1,16 @@
{ %FAIL }
program tprocvar14;
{$mode delphi}
type C = class end;
type H = class helper for C
class procedure NonStatic;
end;
class procedure H.NonStatic; begin end;
var IncompatWNonStatic: procedure;
begin
IncompatWNonStatic := H.NonStatic;
end.

16
tests/test/tprocvar15.pp Normal file
View File

@ -0,0 +1,16 @@
{ %FAIL }
program tprocvar15;
{$mode delphi}
type C = class end;
type H = class helper for C
class procedure Static; static;
end;
class procedure H.Static; begin end;
var IncompatWStatic: procedure of object;
begin
IncompatWStatic := H.Static;
end.