* Patch from Rika to implement BitTestAndSet

packages/fcl-base/src/syncobjs.pp

@@ -99,6 +99,8 @@ type
 {$DEFINE NOPOINTER}
 {$ENDIF}
 
+  TBitOffset = 0 .. 31;
+
   TInterlocked = class sealed
     class function Add(var Target: Longint; aIncrement: Longint): Longint; overload; static; inline;
     class function Exchange(var Target: Longint; Value: Longint): Longint; overload; static; inline;
@@ -106,6 +108,10 @@ type
     class function CompareExchange(var Target: Longint; Value: Longint; Comparand: Longint; out Succeeded: Boolean): Longint; overload; static;
     class function Decrement(var Target: Longint): Longint; overload; static; inline;
     class function Increment(var Target: Longint): Longint; overload; static; inline;
+
+    class function BitTestAndSet(var Target: Longint; BitOffset: TBitOffset): Boolean; static;
+    class function BitTestAndClear(var Target: Longint; BitOffset: TBitOffset): Boolean; static;
+
 {$ifdef FPC_HAS_TYPE_SINGLE}
     class function Exchange(var Target: Single; Value: Single): Single; overload; static; inline;
     class function CompareExchange(var Target: Single; Value: Single; Comparand: Single): Single; overload; static; inline;
@@ -395,29 +401,41 @@ begin
   Result := InterLockedIncrement(Target); // returns new value
 end;
 
+class function TInterlocked.BitTestAndSet(var Target: Longint; BitOffset: TBitOffset): Boolean;
+var
+  Fetch, NewValue: Longint;
+begin
+  repeat
+    Fetch := Target;
+    Result := Boolean(Fetch shr BitOffset and 1);
+    NewValue := Fetch or Longint(1) shl BitOffset;
+  until InterlockedCompareExchange(Target, NewValue, Fetch) = Fetch;
+end;
+
+class function TInterlocked.BitTestAndClear(var Target: Longint; BitOffset: TBitOffset): Boolean;
+var
+  Fetch, NewValue: Longint;
+begin
+  repeat
+    Fetch := Target;
+    Result := Boolean(Fetch shr BitOffset and 1);
+    NewValue := Fetch and not (Longint(1) shl BitOffset);
+  until InterlockedCompareExchange(Target, NewValue, Fetch) = Fetch;
+end;
+
 { ---------------------------------------------------------------------
   32-bit single versions
   ---------------------------------------------------------------------}
 
 {$ifdef FPC_HAS_TYPE_SINGLE}
 class function TInterlocked.Exchange(var Target: Single; Value: Single): Single; overload; static; inline;
-var
-  IntValue: Longint;
-  SinglePtr: PSingle;
 begin
-  IntValue := TInterlocked.Exchange(Longint(Target), Longint(Value));
-  SinglePtr := @IntValue;
-  Result := SinglePtr^;
+  Result := TSingleRec(TInterlocked.Exchange(Longint(Target), Longint(Value))).Value;
 end;
 
 class function TInterlocked.CompareExchange(var Target: Single; Value: Single; Comparand: Single): Single; overload; static; inline;
-var
-  IntValue: Longint;
-  SinglePtr: PSingle;
 begin
-  IntValue := TInterlocked.CompareExchange(Longint(Target), Longint(Value), Longint(Comparand));
-  SinglePtr := @IntValue;
-  Result := SinglePtr^;
+  Result := TSingleRec(TInterlocked.CompareExchange(Longint(Target), Longint(Value), Longint(Comparand))).Value;
 end;
 {$endif}
 
@@ -465,25 +483,15 @@ end;
 
 {$ifdef FPC_HAS_TYPE_DOUBLE}
 class function TInterlocked.CompareExchange(var Target: Double; Value: Double; Comparand: Double): Double; overload; static; inline;
-var
-  Int64Value: Int64;
-  DoublePtr: PDouble;
 begin
-  Int64Value := TInterlocked.CompareExchange(Int64(Target), Int64(Value), Int64(Comparand));
-  DoublePtr := @Int64Value;
-  Result := DoublePtr^;
+  Result := TDoubleRec(TInterlocked.CompareExchange(Int64(Target), Int64(Value), Int64(Comparand))).Value;
 end;
 {$endif}
 
 {$ifdef FPC_HAS_TYPE_DOUBLE}
 class function TInterlocked.Exchange(var Target: Double; Value: Double): Double; overload; static; inline;
-var
-  Int64Value: Int64;
-  DoublePtr: PDouble;
 begin
-  Int64Value := TInterlocked.Exchange(Int64(Target), Int64(Value));
-  DoublePtr := @Int64Value;
-  Result := DoublePtr^;
+  Result := TDoubleRec(TInterlocked.Exchange(Int64(Target), Int64(Value))).Value;
 end;
 {$endif}
 

packages/fcl-base/tests/testinterlocked.pp

@@ -10,7 +10,7 @@ var
   New32, Old32: Longint;
   i64: Int64;
   New64, Old64: Int64;
-  Changed: Boolean;
+  Changed, OldBitValue: Boolean;
   list1, list2, oldlist: TStringList;
   d1, d2, dOld: Double;
   s1, s2, sOld: Single;
@@ -50,6 +50,7 @@ begin
   if Old32 <> 48 then halt(15);
   if i32 <> 96 then halt(15);
 
+{$ifdef cpu64}
   {* test all kinds of Int64 usage *}
   i64 := 12;
   New64 := TInterlocked.Increment(i64);
@@ -75,6 +76,7 @@ begin
   Old64 := TInterlocked.Read(i64);
   if Old64 <> 48 then halt(30);
   if i64 <> 48 then halt(31);
+{$endif}
 
   {* test all kinds of TObject and generic class usage *}
   list1 := TStringList.Create;
@@ -112,6 +114,7 @@ begin
 
   writeln('tests passed so far');
 
+{$ifdef cpu64}
   {* test all kinds of Double usage *}
   d1 := Double(3.14);
   d2 := Double(6.28);
@@ -130,6 +133,7 @@ begin
   if dOld <> Double(6.28) then halt(50);
   if d1 <> Double(3.14) then halt(51);
   if d1 = d2 then halt(52);
+{$endif}
 
   {* test all kinds of Single usage *}
   s1 := Single(3.14);
@@ -150,19 +154,21 @@ begin
   if s1 <> s2 then halt(61);
 
   {* test BitTestAndClear usage *}
-{
-  // enable when implemented!
   i32 := 96;
-  Changed := TInterlocked.BitTestAndClear(i32, 6);
-  if Changed <> True then halt(62);
+  OldBitValue := TInterlocked.BitTestAndClear(i32, 6);
+  if OldBitValue <> True then halt(62);
   if i32 <> 32 then halt(63);
-}
+  OldBitValue := TInterlocked.BitTestAndClear(i32, 6);
+  if OldBitValue <> False then halt(64);
+  if i32 <> 32 then halt(65);
+
   {* test BitTestAndSet usage *}
-{
-  // enable when implemented!
-  Changed := TInterlocked.BitTestAndSet(i32, 4);
-  if Changed <> False then halt(64);
-  if i32 <> 48 then halt(65);
-}
+  OldBitValue := TInterlocked.BitTestAndSet(i32, 6);
+  if OldBitValue <> False then halt(66);
+  if i32 <> 96 then halt(67);
+  OldBitValue := TInterlocked.BitTestAndSet(i32, 6);
+  if OldBitValue <> True then halt(68);
+  if i32 <> 96 then halt(69);
+
   writeln('testing of TInterlocked methods ended');
 end.