Browse Source

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 -
svenbarth 12 years ago
parent
commit
fbceb574eb
5 changed files with 49 additions and 0 deletions
  1. 1 0
      .gitattributes
  2. 3 0
      rtl/beos/tthread.inc
  3. 2 0
      rtl/netwlibc/tthread.inc
  4. 2 0
      rtl/unix/tthread.inc
  5. 41 0
      tests/test/tthread1.pp

+ 1 - 0
.gitattributes

@@ -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

+ 3 - 0
rtl/beos/tthread.inc

@@ -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;

+ 2 - 0
rtl/netwlibc/tthread.inc

@@ -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;

+ 2 - 0
rtl/unix/tthread.inc

@@ -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 - 0
tests/test/tthread1.pp

@@ -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.