* fix #40221: don't allow a conversion from an anonymous function to a procvar type if compare_defs_ext already rejected them

+ added tests
This commit is contained in:
Sven/Sarah Barth 2023-06-16 17:28:50 +02:00
parent e44a33a78b
commit 0b7a771ca9
3 changed files with 48 additions and 2 deletions

View File

@ -2508,7 +2508,10 @@ implementation
not is_self_sym(tsym(pcapturedsyminfo(tprocdef(pd).capturedsyms[0])^.sym))
)
) then
internalerror(2021060801);
begin
result:=cerrornode.create;
exit;
end;
{ so that insert_self_and_vmt_para correctly inserts the
Self, cause it otherwise skips that for anonymous functions }
@ -2619,7 +2622,10 @@ implementation
else if tprocvardef(totypedef).is_addressonly then
begin
if assigned(tprocdef(pd).capturedsyms) and (tprocdef(pd).capturedsyms.count>0) then
internalerror(2021060802);
begin
result:=cerrornode.create;
exit;
end;
{ remove framepointer and Self parameters }
for i:=tprocdef(pd).parast.symlist.count-1 downto 0 do
@ -3172,6 +3178,14 @@ implementation
not(is_open_array(left.resultdef)) and
not(is_array_constructor(left.resultdef)) and
not(is_array_of_const(left.resultdef)) and
{ if the from type is an anonymous function then
don't blindly convert it if the size is the same
as compare_defs_ext already determined that the
anonymous function is not compatible }
not(
(left.resultdef.typ=procdef) and
(po_anonymous in tprocdef(left.resultdef).procoptions)
) and
(left.resultdef.size=resultdef.size) and
{ disallow casts of const nodes }
(not is_constnode(left) or

15
tests/webtbf/tw40221a.pp Normal file
View File

@ -0,0 +1,15 @@
{ %FAIL }
{$mode objfpc} {$modeswitch anonymousfunctions}
procedure Main;
var
c: int32;
begin
c := 12;
TProcedure(procedure begin writeln(c); end);
end;
begin
Main;
end.

17
tests/webtbf/tw40221b.pp Normal file
View File

@ -0,0 +1,17 @@
{ %FAIL }
{$mode objfpc} {$modeswitch anonymousfunctions}
procedure Main;
type
TProcMethod = procedure of object;
var
c: int32;
begin
c := 12;
TProcMethod(procedure begin writeln(c); end);
end;
begin
Main;
end.