mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-08-10 01:46:58 +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;
|
||||
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
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