mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-04-20 21:09:24 +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/tb0612.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/tb610.pp svneol=native#text/pascal
|
||||
tests/tbs/tb613.pp svneol=native#text/plain
|
||||
|
@ -4168,6 +4168,9 @@ implementation
|
||||
calln to a loadn (PFV) }
|
||||
if assigned(methodpointer) then
|
||||
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 }
|
||||
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