Hi all,
I have some code for a thread-safe queue that works just fine in Delphi, but I want see if I can make it work under freepascal, and if possible, cross-platform compatible too which would be even better
Any ideas?
PS. I haven't actually tried compiling it under freepascal yet, but I have suspicions that it won't due to the units being used...
[pascal]
Unit threadsafe_queue;
{$IFDEF fpc}
{$MODE DELPHI} {$H+}
{$ENDIF}
Interface
Uses
Windows,
Contnrs,
Syncobjs;
{
As many consumer threads as you like can wait on the queue with no CPU
waste. When objects come in, waiting threads are woken up. Note that the
'pop' method takes a pointer to the variable where an incoming object is to
be placed, (avoids need for casting):
Var
inObject: TobjectOfSomeClass;
..
..
if (myThreadSafeQueue.pop(@inObject,INFINITE))then
handleObject
else
// only handled if timeout not INFINITE !!
handleTimeout;
}
Type
{................................................. .............................}
PObject = ^TObject;
TThreadSafeQueue = Class(TObjectQueue)
Private
FCountSema : Thandle;
FAccess : TCriticalSection;
Public
Constructor Create;
Procedure Push(Const AObject : TObject);
Function Pop (Const AObject : PObject;
Const Timeout : LongWord) : Boolean;
Destructor Destroy; Override;
End;
{................................................. .............................}
Implementation
{................................................. .............................}
{................................................. .............................}
Constructor TThreadSafeQueue.Create;
Begin
Inherited create;
FAccess := TCriticalSection.Create;
FCountSema := CreateSemaphore(Nil,0,MaxInt,Nil);
End;
{................................................. .............................}
{................................................. .............................}
Destructor TThreadSafeQueue.Destroy;
Begin
CloseHandle(FCountSema);
FAccess.Free;
Inherited Destroy;
End;
{................................................. .............................}
{................................................. .............................}
Function TThreadSafeQueue.Pop(Const AObject : PObject;
Const Timeout : LongWord) : Boolean;
Begin
Result := (WAIT_OBJECT_0 = WaitForSingleObject(FCountSema,Timeout));
If Result Then
Begin
FAccess.Acquire;
Try
AObject^ := Inherited Pop;
Finally
FAccess.Release;
End;
End;
End;
{................................................. .............................}
{................................................. .............................}
Procedure TThreadSafeQueue.Push(Const AObject : TObject);
Begin
FAccess.Acquire;
Try
Inherited Push(AObject);
Finally
FAccess.Release;
End;
ReleaseSemaphore(FCountSema,1,Nil);
End;
{................................................. .............................}
{................................................. .............................}
End.[/pascal]
Cheers,
Paul
Reply With Quote
Originally Posted by technomage
Bookmarks