mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-04-09 20:28:49 +02:00
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:
parent
900afaddea
commit
fbceb574eb
1
.gitattributes
vendored
1
.gitattributes
vendored
@ -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
|
||||
|
@ -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;
|
||||
|
@ -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;
|
||||
|
@ -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
41
tests/test/tthread1.pp
Normal 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.
|
Loading…
Reference in New Issue
Block a user