mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-08-13 21:02:09 +02:00
* fixed with r1182
git-svn-id: trunk@1190 -
This commit is contained in:
parent
6e2a771c41
commit
291db810bd
1
.gitattributes
vendored
1
.gitattributes
vendored
@ -6214,6 +6214,7 @@ tests/webtbs/tw4162.pp svneol=native#text/plain
|
|||||||
tests/webtbs/tw4173.pp svneol=native#text/plain
|
tests/webtbs/tw4173.pp svneol=native#text/plain
|
||||||
tests/webtbs/tw4188.pp svneol=native#text/plain
|
tests/webtbs/tw4188.pp svneol=native#text/plain
|
||||||
tests/webtbs/tw4199.pp svneol=native#text/plain
|
tests/webtbs/tw4199.pp svneol=native#text/plain
|
||||||
|
tests/webtbs/tw4201.pp svneol=native#text/plain
|
||||||
tests/webtbs/tw4202.pp svneol=native#text/plain
|
tests/webtbs/tw4202.pp svneol=native#text/plain
|
||||||
tests/webtbs/tw4215.pp svneol=native#text/plain
|
tests/webtbs/tw4215.pp svneol=native#text/plain
|
||||||
tests/webtbs/tw4219.pp svneol=native#text/plain
|
tests/webtbs/tw4219.pp svneol=native#text/plain
|
||||||
|
75
tests/webtbs/tw4201.pp
Normal file
75
tests/webtbs/tw4201.pp
Normal file
@ -0,0 +1,75 @@
|
|||||||
|
{ Source provided for Free Pascal Bug Report 4201 }
|
||||||
|
{ Submitted by "Gergely Nagy" on 2005-07-19 }
|
||||||
|
{ e-mail: gergely.nagy@softreal.hu }
|
||||||
|
{ TThread.Synchronize on an abstract virtual method bug demonstration
|
||||||
|
by Gergely Nagy <gergely.nagy@softreal.hu> }
|
||||||
|
|
||||||
|
{$mode delphi}
|
||||||
|
program fp_thread_bug_test;
|
||||||
|
|
||||||
|
uses
|
||||||
|
{$ifdef unix}
|
||||||
|
CThreads,
|
||||||
|
{$endif unix}
|
||||||
|
Classes;
|
||||||
|
|
||||||
|
type
|
||||||
|
TBuggedBaseThread = class;
|
||||||
|
|
||||||
|
TBuggedBaseThread = class (TThread)
|
||||||
|
protected
|
||||||
|
procedure Execute; override;
|
||||||
|
function ExecuteOperation: Boolean; virtual; abstract;
|
||||||
|
procedure EndOperation; virtual; abstract;
|
||||||
|
public
|
||||||
|
constructor Create;
|
||||||
|
procedure StopThread;
|
||||||
|
end;
|
||||||
|
|
||||||
|
TBuggedThread = class (TBuggedBaseThread)
|
||||||
|
protected
|
||||||
|
function ExecuteOperation: Boolean; override;
|
||||||
|
procedure EndOperation; override;
|
||||||
|
end;
|
||||||
|
|
||||||
|
constructor TBuggedBaseThread.Create;
|
||||||
|
begin
|
||||||
|
inherited Create(True);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TBuggedBaseThread.StopThread;
|
||||||
|
begin
|
||||||
|
Terminate;
|
||||||
|
Suspended:= False;
|
||||||
|
WaitFor;
|
||||||
|
Free;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TBuggedBaseThread.Execute;
|
||||||
|
begin
|
||||||
|
WriteLn ('# Execute...');
|
||||||
|
ExecuteOperation;
|
||||||
|
WriteLn ('# ...Going to sync...');
|
||||||
|
Synchronize(EndOperation);
|
||||||
|
Terminate;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TBuggedThread.EndOperation;
|
||||||
|
begin
|
||||||
|
WriteLn ('# EndOperation');
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TBuggedThread.ExecuteOperation: Boolean;
|
||||||
|
begin
|
||||||
|
WriteLn ('# ExecuteOperation');
|
||||||
|
Result:= True;
|
||||||
|
end;
|
||||||
|
|
||||||
|
var
|
||||||
|
t: TBuggedThread;
|
||||||
|
|
||||||
|
begin
|
||||||
|
t:= TBuggedThread.Create;
|
||||||
|
|
||||||
|
t.Execute;
|
||||||
|
end.
|
Loading…
Reference in New Issue
Block a user