[fpc-pascal] Counting semaphore for free pascal

[kapibara]

Hi there,

A counting, or general, semaphore limits simultaneous access to a 
resource according to the number of permits you specify. On the other 
hand, a binary semaphore like a critical section limits the access to 
"one at a time".

FPC doesn't seem to have a general semaphore? I recently attempted to 
implement one, here is the code, plus a working Lazarus demo attached. 
It blocks on an event instead of a critical section. However, I didnt 
manage to have it block by just calling Wait, because then the code 
blocked without leaving the PermitLock and that meant deadlock for all 
threads. So thats why you see the "if Semaphore.Wait(aEvent) then 
RTLEventWaitFor(aEvent)" instead of just Semaphore.Wait(aEvent). It 
works just fine, but if anyone knows how to implement this by just 
calling Wait(aEvent), please tell. If you want to block on a critical 
section instead of an event, do that. Perhaps the result could be 
TFPSemaphore and go with FPC.

unit kbsemaphore;

{$mode objfpc}{$H+}

interface

uses
   Classes, SysUtils, syncobjs, contnrs;

type

   { TKBSemaphore }

   TKBSemaphore = class
   private
     FPermits: Cardinal;
     FPermitLock: TCriticalSection;
     FBlockQueue: TQueue;
     function GetWaitCount: Cardinal;
   public
     function Wait(var AEvent: PRTLEvent): Boolean;
     procedure Post;
     constructor Create(MaxPermits: Cardinal);
     destructor Destroy; override;
     property WaitCount: Cardinal read GetWaitCount;  //Approximate 
precision!
     property Permits: Cardinal read FPermits;
   end;


implementation

{ TKBSemaphore }

function TKBSemaphore.GetWaitCount: Cardinal;
begin
   FPermitLock.Enter;
   Result:= FBlockQueue.Count;
   FPermitLock.Leave;
end;

function TKBSemaphore.Wait(var AEvent: PRTLEvent): Boolean;
begin
   FPermitLock.Enter;
   if (FPermits > 0) then
   begin
     Dec(FPermits);
     Result:= False;
   end
   else
   begin
     AEvent:= RTLEventCreate;
     FBlockQueue.Push(AEvent);
     Result:= True;
   end;
   FPermitLock.Leave;
end;

procedure TKBSemaphore.Post;
begin
   FPermitLock.Enter;
   if FBlockQueue.Count > 0 then
   begin
     RTLeventSetEvent(PRTLEvent(FBlockQueue.Peek));
     RTLeventdestroy(PRTLEvent(FBlockQueue.Pop));
   end
   else
     Inc(FPermits);

   FPermitLock.Leave;
end;

constructor TKBSemaphore.Create(MaxPermits: Cardinal);
begin
   FPermits:= MaxPermits;
   FPermitLock:= TCriticalSection.Create;
   FBlockQueue:= TQueue.Create;
end;

destructor TKBSemaphore.Destroy;
begin
   FPermitLock.Free;
   FBlockQueue.Free;
   inherited Destroy;
end;

end.

-------------- next part --------------
A non-text attachment was scrubbed...
Name: KBSemaphoreDemo.zip
Type: application/x-zip-compressed
Size: 5157 bytes
Desc: not available
URL: <http://lists.freepascal.org/pipermail/fpc-pascal/attachments/20150728/127bb395/attachment.bin>