------- Additional Comments From dannysmith at users dot sourceforge dot net
2005-03-19 11:14 -------
IMO, resetting the error code set by the kernel whenever the internal Ada
tasking functions are called successfully is a bug. It can be easily fixed:
* s-osinte-mingw.ads (SetLastError): Import win32api function.
* s-taprop-mingw.adb (Specific.Is_Valid_Task): Save last OS
error code and restore if TlsGetValue succeeds.
(Specific.Set): Likewise.
Index: s-osinte-mingw.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/s-osinte-mingw.ads,v
retrieving revision 1.1
diff -c -3 -p -r1.1 s-osinte-mingw.ads
*** s-osinte-mingw.ads 14 May 2004 10:02:00 -0000 1.1
--- s-osinte-mingw.ads 19 Mar 2005 10:57:53 -0000
*************** pragma Preelaborate;
*** 433,438 ****
--- 433,441 ----
function GetLastError return DWORD;
pragma Import (Stdcall, GetLastError, "GetLastError");
+ procedure SetLastError (dwErrCode : DWORD);
+ pragma Import (Stdcall, SetLastError, "SetLastError");
+
private
type sigset_t is new Interfaces.C.unsigned_long;
Index: s-taprop-mingw.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/s-taprop-mingw.adb,v
retrieving revision 1.7
diff -c -3 -p -r1.7 s-taprop-mingw.adb
*** s-taprop-mingw.adb 10 Feb 2005 13:57:21 -0000 1.7
--- s-taprop-mingw.adb 19 Mar 2005 10:57:55 -0000
*************** package body System.Task_Primitives.Oper
*** 143,160 ****
end Specific;
package body Specific is
function Is_Valid_Task return Boolean is
begin
! return TlsGetValue (TlsIndex) /= System.Null_Address;
end Is_Valid_Task;
procedure Set (Self_Id : Task_Id) is
Succeeded : BOOL;
begin
Succeeded := TlsSetValue (TlsIndex, To_Address (Self_Id));
pragma Assert (Succeeded = True);
end Set;
end Specific;
--- 143,174 ----
end Specific;
+ -- Unlike other win32api functions, TlsGetValue resets the OS error
+ -- status to O on success. Save and restore the error code so it
+ -- doesn't get clobbered behind the user's back when multi-tasking.
+
package body Specific is
function Is_Valid_Task return Boolean is
+ Succeeded : Boolean;
+ Saved_Err_Code : DWORD;
begin
! Saved_Err_Code := GetLastError;
! Succeeded := TlsGetValue (TlsIndex) /= System.Null_Address;
! if Succeeded then
! SetLastError (Saved_Err_Code);
! end if;
! return Succeeded;
end Is_Valid_Task;
procedure Set (Self_Id : Task_Id) is
Succeeded : BOOL;
+ Saved_Err_Code : DWORD;
begin
+ Saved_Err_Code := GetLastError;
Succeeded := TlsSetValue (TlsIndex, To_Address (Self_Id));
pragma Assert (Succeeded = True);
+ SetLastError (Saved_Err_Code);
end Set;
end Specific;
--
http://gcc.gnu.org/bugzilla/show_bug.cgi?id=19526
