mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-08-15 00:29:24 +02:00
* 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:
parent
a8cf67d73b
commit
6e7a82440e
@ -2494,6 +2494,7 @@ implementation
|
|||||||
aprocdef : tprocdef;
|
aprocdef : tprocdef;
|
||||||
eq : tequaltype;
|
eq : tequaltype;
|
||||||
cdoptions : tcompare_defs_options;
|
cdoptions : tcompare_defs_options;
|
||||||
|
selfnode : tnode;
|
||||||
newblock: tblocknode;
|
newblock: tblocknode;
|
||||||
newstatement: tstatementnode;
|
newstatement: tstatementnode;
|
||||||
tempnode: ttempcreatenode;
|
tempnode: ttempcreatenode;
|
||||||
@ -2657,8 +2658,14 @@ implementation
|
|||||||
tprocdef(currprocdef),tcallnode(left).symtableproc);
|
tprocdef(currprocdef),tcallnode(left).symtableproc);
|
||||||
if (tcallnode(left).symtableprocentry.owner.symtabletype=ObjectSymtable) then
|
if (tcallnode(left).symtableprocentry.owner.symtabletype=ObjectSymtable) then
|
||||||
begin
|
begin
|
||||||
if assigned(tcallnode(left).methodpointer) then
|
selfnode:=tcallnode(left).methodpointer;
|
||||||
tloadnode(hp).set_mp(tcallnode(left).methodpointer.getcopy)
|
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
|
else
|
||||||
tloadnode(hp).set_mp(load_self_node);
|
tloadnode(hp).set_mp(load_self_node);
|
||||||
end;
|
end;
|
||||||
|
17
tests/test/tprocvar11.pp
Normal file
17
tests/test/tprocvar11.pp
Normal 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
17
tests/test/tprocvar12.pp
Normal 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
15
tests/test/tprocvar13.pp
Normal 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
16
tests/test/tprocvar14.pp
Normal 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
16
tests/test/tprocvar15.pp
Normal 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.
|
Loading…
Reference in New Issue
Block a user