mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-08-18 19:49:12 +02:00
* fixed a bug, which caused a function that returns a method pointer (or nested
procdef) to be called twice, when the result of this function is immediately called (i.e. not stored in a temp variable). git-svn-id: trunk@32495 -
This commit is contained in:
parent
7d1889e0ef
commit
e6d01eb3b5
1
.gitattributes
vendored
1
.gitattributes
vendored
@ -10824,6 +10824,7 @@ tests/tbs/tb0610.pp svneol=native#text/pascal
|
|||||||
tests/tbs/tb0611.pp svneol=native#text/pascal
|
tests/tbs/tb0611.pp svneol=native#text/pascal
|
||||||
tests/tbs/tb0612.pp svneol=native#text/pascal
|
tests/tbs/tb0612.pp svneol=native#text/pascal
|
||||||
tests/tbs/tb0613.pp svneol=native#text/pascal
|
tests/tbs/tb0613.pp svneol=native#text/pascal
|
||||||
|
tests/tbs/tb0614.pp svneol=native#text/pascal
|
||||||
tests/tbs/tb205.pp svneol=native#text/plain
|
tests/tbs/tb205.pp svneol=native#text/plain
|
||||||
tests/tbs/tb610.pp svneol=native#text/pascal
|
tests/tbs/tb610.pp svneol=native#text/pascal
|
||||||
tests/tbs/tb613.pp svneol=native#text/plain
|
tests/tbs/tb613.pp svneol=native#text/plain
|
||||||
|
@ -4168,6 +4168,9 @@ implementation
|
|||||||
calln to a loadn (PFV) }
|
calln to a loadn (PFV) }
|
||||||
if assigned(methodpointer) then
|
if assigned(methodpointer) then
|
||||||
maybe_load_in_temp(methodpointer);
|
maybe_load_in_temp(methodpointer);
|
||||||
|
if assigned(right) and (right.resultdef.typ=procvardef) and
|
||||||
|
not tabstractprocdef(right.resultdef).is_addressonly then
|
||||||
|
maybe_load_in_temp(right);
|
||||||
|
|
||||||
{ Create destination (temp or assignment-variable reuse) for function result if it not yet set }
|
{ Create destination (temp or assignment-variable reuse) for function result if it not yet set }
|
||||||
maybe_create_funcret_node;
|
maybe_create_funcret_node;
|
||||||
|
69
tests/tbs/tb0614.pp
Normal file
69
tests/tbs/tb0614.pp
Normal file
@ -0,0 +1,69 @@
|
|||||||
|
program tb0614;
|
||||||
|
|
||||||
|
{$mode objfpc}
|
||||||
|
{$modeswitch nestedprocvars}
|
||||||
|
|
||||||
|
type
|
||||||
|
tobjectmethod = procedure of object;
|
||||||
|
tnestedprocvar = procedure is nested;
|
||||||
|
|
||||||
|
TMyClass = class
|
||||||
|
procedure Moo;
|
||||||
|
end;
|
||||||
|
|
||||||
|
var
|
||||||
|
obj: TMyClass;
|
||||||
|
NumCalls: Integer;
|
||||||
|
|
||||||
|
procedure TMyClass.Moo;
|
||||||
|
begin
|
||||||
|
Writeln('TMyClass.Moo');
|
||||||
|
end;
|
||||||
|
|
||||||
|
function get_objmethod: tobjectmethod;
|
||||||
|
begin
|
||||||
|
Writeln('get_objmethod');
|
||||||
|
Inc(NumCalls);
|
||||||
|
Result := @obj.Moo;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function get_nestedprocvar: tnestedprocvar;
|
||||||
|
procedure nested;
|
||||||
|
begin
|
||||||
|
Writeln('nested');
|
||||||
|
end;
|
||||||
|
begin
|
||||||
|
Writeln('get_nestedprocvar');
|
||||||
|
Inc(NumCalls);
|
||||||
|
Result := @nested;
|
||||||
|
end;
|
||||||
|
|
||||||
|
var
|
||||||
|
Errors: Boolean = False;
|
||||||
|
begin
|
||||||
|
NumCalls := 0;
|
||||||
|
obj := TMyClass.Create;
|
||||||
|
get_objmethod()();
|
||||||
|
obj.Free;
|
||||||
|
if NumCalls <> 1 then
|
||||||
|
begin
|
||||||
|
Writeln('Error: get_objmethod should have been called once, but instead it was called ', NumCalls, ' times');
|
||||||
|
Errors := True;
|
||||||
|
end;
|
||||||
|
|
||||||
|
NumCalls := 0;
|
||||||
|
get_nestedprocvar()();
|
||||||
|
if NumCalls <> 1 then
|
||||||
|
begin
|
||||||
|
Writeln('Error: get_nestedprocvar should have been called once, but instead it was called ', NumCalls, ' times');
|
||||||
|
Errors := True;
|
||||||
|
end;
|
||||||
|
|
||||||
|
if Errors then
|
||||||
|
begin
|
||||||
|
Writeln('Errors found!');
|
||||||
|
Halt(1);
|
||||||
|
end
|
||||||
|
else
|
||||||
|
Writeln('Ok!');
|
||||||
|
end.
|
Loading…
Reference in New Issue
Block a user