Fix for Mantis #25041 . Correctly set CurrentThreadVar for those tthread.inc incarnations that don't use the default ThreadProc in classes.inc (this should be changed in the future though...). In addition to Unix systems as described by the bug report this also involved BeOS and Netware LibC.

+ added test

git-svn-id: trunk@25511 -
This commit is contained in:
svenbarth 2013-09-17 18:02:12 +00:00
parent 900afaddea
commit fbceb574eb
5 changed files with 49 additions and 0 deletions

1
.gitattributes vendored
View File

@ -11864,6 +11864,7 @@ tests/test/tthlp6.pp svneol=native#text/pascal
tests/test/tthlp7.pp svneol=native#text/pascal
tests/test/tthlp8.pp svneol=native#text/pascal
tests/test/tthlp9.pp svneol=native#text/pascal
tests/test/tthread1.pp svneol=native#text/pascal
tests/test/ttpara1.pp svneol=native#text/plain
tests/test/ttpara2.pp svneol=native#text/plain
tests/test/ttypeconvtypes.pp svneol=native#text/pascal

View File

@ -151,6 +151,7 @@ begin
while Thread.FHandle = 0 do fpsleep(1);
if Thread.FSuspended then Thread.suspend();
try
CurrentThreadVar := Thread;
Thread.Execute;
except
Thread.FFatalException := TObject(AcquireExceptionObject);
@ -423,10 +424,12 @@ begin
if LThread.FInitialSuspended then begin
SemaphoreWait(LThread.FSem);
if not LThread.FInitialSuspended then begin
CurrentThreadVar := LThread;
WRITE_DEBUG('going into LThread.Execute');
LThread.Execute;
end;
end else begin
CurrentThreadVar := LThread;
WRITE_DEBUG('going into LThread.Execute');
LThread.Execute;
end;

View File

@ -226,10 +226,12 @@ begin
if LThread.FInitialSuspended then begin
LThread.Suspend;
if not LThread.FInitialSuspended then begin
CurrentThreadVar := LThread;
WRITE_DEBUG('going into LThread.Execute'#13#10);
LThread.Execute;
end;
end else begin
CurrentThreadVar := LThread;
WRITE_DEBUG('going into LThread.Execute'#13#10);
LThread.Execute;
end;

View File

@ -111,6 +111,7 @@ begin
if not LThread.FSuspended then
begin
LThread.FInitialSuspended := false;
CurrentThreadVar := LThread;
WRITE_DEBUG('going into LThread.Execute');
LThread.Execute;
end
@ -125,6 +126,7 @@ begin
LThread.FSuspendedInternal := true;
WRITE_DEBUG('waiting for SuspendedInternal - ', LThread.ClassName);
CurrentTM.SemaphoreWait(LThread.FSem);
CurrentThreadVar := LThread;
WRITE_DEBUG('going into LThread.Execute - ', LThread.ClassName);
LThread.Execute;
end;

41
tests/test/tthread1.pp Normal file
View File

@ -0,0 +1,41 @@
program tthread1;
{$mode objfpc}
uses
{$ifdef unix}
cthreads,
{$endif}
Classes;
type
TTestThread = class(TThread)
protected
procedure Execute; override;
public
property ReturnValue;
end;
procedure TTestThread.Execute;
var
thrd: TThread;
begin
thrd := CurrentThread;
if thrd <> Self then
ReturnValue := 1
else
ReturnValue := 0;
end;
var
t: TTestThread;
begin
t := TTestThread.Create(False);
try
t.WaitFor;
ExitCode := t.ReturnValue;
finally
t.Free;
end;
Writeln(ExitCode);
end.