mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-11-23 13:51:30 +01: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/tthlp7.pp svneol=native#text/pascal
|
||||||
tests/test/tthlp8.pp svneol=native#text/pascal
|
tests/test/tthlp8.pp svneol=native#text/pascal
|
||||||
tests/test/tthlp9.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/ttpara1.pp svneol=native#text/plain
|
||||||
tests/test/ttpara2.pp svneol=native#text/plain
|
tests/test/ttpara2.pp svneol=native#text/plain
|
||||||
tests/test/ttypeconvtypes.pp svneol=native#text/pascal
|
tests/test/ttypeconvtypes.pp svneol=native#text/pascal
|
||||||
|
|||||||
@ -151,6 +151,7 @@ begin
|
|||||||
while Thread.FHandle = 0 do fpsleep(1);
|
while Thread.FHandle = 0 do fpsleep(1);
|
||||||
if Thread.FSuspended then Thread.suspend();
|
if Thread.FSuspended then Thread.suspend();
|
||||||
try
|
try
|
||||||
|
CurrentThreadVar := Thread;
|
||||||
Thread.Execute;
|
Thread.Execute;
|
||||||
except
|
except
|
||||||
Thread.FFatalException := TObject(AcquireExceptionObject);
|
Thread.FFatalException := TObject(AcquireExceptionObject);
|
||||||
@ -423,10 +424,12 @@ begin
|
|||||||
if LThread.FInitialSuspended then begin
|
if LThread.FInitialSuspended then begin
|
||||||
SemaphoreWait(LThread.FSem);
|
SemaphoreWait(LThread.FSem);
|
||||||
if not LThread.FInitialSuspended then begin
|
if not LThread.FInitialSuspended then begin
|
||||||
|
CurrentThreadVar := LThread;
|
||||||
WRITE_DEBUG('going into LThread.Execute');
|
WRITE_DEBUG('going into LThread.Execute');
|
||||||
LThread.Execute;
|
LThread.Execute;
|
||||||
end;
|
end;
|
||||||
end else begin
|
end else begin
|
||||||
|
CurrentThreadVar := LThread;
|
||||||
WRITE_DEBUG('going into LThread.Execute');
|
WRITE_DEBUG('going into LThread.Execute');
|
||||||
LThread.Execute;
|
LThread.Execute;
|
||||||
end;
|
end;
|
||||||
|
|||||||
@ -226,10 +226,12 @@ begin
|
|||||||
if LThread.FInitialSuspended then begin
|
if LThread.FInitialSuspended then begin
|
||||||
LThread.Suspend;
|
LThread.Suspend;
|
||||||
if not LThread.FInitialSuspended then begin
|
if not LThread.FInitialSuspended then begin
|
||||||
|
CurrentThreadVar := LThread;
|
||||||
WRITE_DEBUG('going into LThread.Execute'#13#10);
|
WRITE_DEBUG('going into LThread.Execute'#13#10);
|
||||||
LThread.Execute;
|
LThread.Execute;
|
||||||
end;
|
end;
|
||||||
end else begin
|
end else begin
|
||||||
|
CurrentThreadVar := LThread;
|
||||||
WRITE_DEBUG('going into LThread.Execute'#13#10);
|
WRITE_DEBUG('going into LThread.Execute'#13#10);
|
||||||
LThread.Execute;
|
LThread.Execute;
|
||||||
end;
|
end;
|
||||||
|
|||||||
@ -111,6 +111,7 @@ begin
|
|||||||
if not LThread.FSuspended then
|
if not LThread.FSuspended then
|
||||||
begin
|
begin
|
||||||
LThread.FInitialSuspended := false;
|
LThread.FInitialSuspended := false;
|
||||||
|
CurrentThreadVar := LThread;
|
||||||
WRITE_DEBUG('going into LThread.Execute');
|
WRITE_DEBUG('going into LThread.Execute');
|
||||||
LThread.Execute;
|
LThread.Execute;
|
||||||
end
|
end
|
||||||
@ -125,6 +126,7 @@ begin
|
|||||||
LThread.FSuspendedInternal := true;
|
LThread.FSuspendedInternal := true;
|
||||||
WRITE_DEBUG('waiting for SuspendedInternal - ', LThread.ClassName);
|
WRITE_DEBUG('waiting for SuspendedInternal - ', LThread.ClassName);
|
||||||
CurrentTM.SemaphoreWait(LThread.FSem);
|
CurrentTM.SemaphoreWait(LThread.FSem);
|
||||||
|
CurrentThreadVar := LThread;
|
||||||
WRITE_DEBUG('going into LThread.Execute - ', LThread.ClassName);
|
WRITE_DEBUG('going into LThread.Execute - ', LThread.ClassName);
|
||||||
LThread.Execute;
|
LThread.Execute;
|
||||||
end;
|
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