paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-06 10:07:54 +02:00
Code Issues Packages Projects Releases Wiki Activity

* correctly handle reading of class/object pointers in combination with @, resolves #26326

Browse Source 
git-svn-id: trunk@43804 -
This commit is contained in:
florian 2019-12-28 17:59:23 +00:00
parent 1c171e1ad3
commit 00859420ab
4 changed files with 57 additions and 11 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.gitattributes vendored
View File

@ -17318,6 +17318,7 @@ tests/webtbs/tw2627.pp svneol=native#text/plain
tests/webtbs/tw26271.pp svneol=native#text/pascal
tests/webtbs/tw26288.pp svneol=native#text/pascal
tests/webtbs/tw2631.pp svneol=native#text/plain
tests/webtbs/tw26326.pp svneol=native#text/pascal
tests/webtbs/tw26402.pp svneol=native#text/plain
tests/webtbs/tw26403.pp svneol=native#text/pascal
tests/webtbs/tw26408.pp svneol=native#text/pascal

5
compiler/htypechk.pas
View File

@ -1297,6 +1297,9 @@ implementation
break;
loadn :
begin
{ the class pointer is read }
if assigned(tunarynode(p).left) then
set_varstate(tunarynode(p).left,vs_read,[vsf_must_be_valid]);
if (tloadnode(p).symtableentry.typ in [localvarsym,paravarsym,staticvarsym]) then
begin
hsym:=tabstractvarsym(tloadnode(p).symtableentry);
@ -1377,6 +1380,8 @@ implementation
end;
break;
end;
addrn:
break;
callparan :
internalerror(200310081);
else

31
compiler/nmem.pas
View File

@ -535,6 +535,22 @@ implementation
function taddrnode.pass_typecheck:tnode;
procedure check_mark_read_written;
begin
if mark_read_written then
begin
{ This is actually only "read", but treat it nevertheless as
modified due to the possible use of pointers
To avoid false positives regarding "uninitialised"
warnings when using arrays, perform it in two steps }
set_varstate(left,vs_written,[]);
{ vsf_must_be_valid so it doesn't get changed into
vsf_referred_not_inited }
set_varstate(left,vs_read,[vsf_must_be_valid]);
end;
end;
var
hp : tnode;
hsym : tfieldvarsym;
@ -629,9 +645,11 @@ implementation
end
else
begin
check_mark_read_written;
{ Return the typeconvn only }
result:=left;
left:=nil;
exit;
end;
end
else
@ -650,17 +668,8 @@ implementation
CGMessage(type_e_variable_id_expected);
end;
if mark_read_written then
begin
{ This is actually only "read", but treat it nevertheless as }
{ modified due to the possible use of pointers }
{ To avoid false positives regarding "uninitialised" }
{ warnings when using arrays, perform it in two steps }
set_varstate(left,vs_written,[]);
{ vsf_must_be_valid so it doesn't get changed into }
{ vsf_referred_not_inited }
set_varstate(left,vs_read,[vsf_must_be_valid]);
end;
check_mark_read_written;
if not(assigned(result)) then
result:=simplify(false);
end;

31
tests/webtbs/tw26326.pp Normal file
View File

@ -0,0 +1,31 @@
{ %opt=-vn -Sen }
{ %norun }
{$mode objfpc}
type
TForm = class
procedure OnClick;
end;
TNotifyEvent = procedure of object;
procedure TForm.OnClick;
begin
end;
procedure Test (aObject: TObject);
var
aForm: TForm;
aEvent: TNotifyEvent;
begin
if (aObject is TForm) then
begin
aForm := aObject as TForm;
aEvent := @aForm.OnClick;
aEvent();
end;
end;
begin
Test(nil);
end.