unit BoundedBuf;
 
{Martin Harvey 24/4/2000}
 
interface
 
uses Windows, SysUtils;
 
const
 DefaultWaitTime = 1000; { Un segundo de espera en todas las primitivas de sincronizacin }
 
type

{ No me agradan particularmente los arreglos dinmicos, de modo que har las cosas

al estilo de “C”, asignando la memoria explcitamente

Piensa en TBufferEntries como ^(array of pointer) }

 
 TBufferEntries = ^Pointer;
 
 TBoundedBuffer = class
 private
 FBufInit: boolean;
 FBufSize: integer;
 FBuf: TBufferEntries;
 FReadPtr, { ReadPtr apunta a la siguiente entrada usada en el buffer}
 FWritePtr: integer; { WritePtr apunta a la siguiente entrada libre en el buffer}
 FEntriesFree, FEntriesUsed: THandle; { Semforos de control de flujo }
 FCriticalMutex: THandle; { Mutex de seccin crtica }
 FEntryCountFree, FEntryCountUsed: integer; { Used for peeking operations }
 protected
 procedure SetSize(NewSize: integer);
 function ControlledWait(Semaphore: THandle): boolean;
 { Returns whether wait returned OK, or an error occurred }
 public
 procedure ResetState;
 destructor Destroy; override;
 function PutItem(NewItem: Pointer): boolean;
 function GetItem: Pointer;
 { New peeking operations. Ntese que no se pueden usar simples propiedades, 
ya que tenermos que comunicar el xito o fracaso de la operacin, adems 
de proveer el resultado }
 function GetEntriesFree(var Free: integer): boolean;
 function GetEntriesUsed(var Used: integer): boolean;
 published
 property Size: integer read FBufSize write SetSize;
 end;
 

{ No se necesita ningn constructor porque los valores por defecto de 0,

false, etc son aceptables }

 
implementation
 
procedure TBoundedBuffer.SetSize(NewSize: integer);
 

{ Inicializa los manejadores y asigna la memoria.

Si el tamao del buffer ha sido establecido con anterioridad, entonces aqui

podra solicitar un reiniciado del buffer. }

 
begin
 if FBufInit then ResetState;
 if NewSize < 2 then NewSize := 2;
 FBufSize := NewSize;
 GetMem(FBuf, Sizeof(Pointer) * FBufSize);
 FillMemory(FBuf, Sizeof(Pointer) * FBufSize, 0);
 FCriticalMutex := CreateMutex(nil, false, nil); { note lack of name }
 WaitForSingleObject(FCriticalMutex, INFINITE);
 FBufInit := true;

{ El coteo inciial del semforo require pensar un poco,

El conteo mximo require pensar un poco ms.

Nuevamente, todos los objetos de sincronizacin son annimos. }

 FEntriesFree := CreateSemaphore(nil, FBufSize - 1, FBufSize, nil);
 FEntriesUsed := CreateSemaphore(nil, 0, FBufSize, nil);
 FEntryCountFree := FBufSize - 1;
 FEntryCountUsed := 0;
 ReleaseMutex(FCriticalMutex);
 if (FCriticalMutex = 0)
 or (FEntriesFree = 0)
 or (FEntriesUsed = 0) then ResetState
end;
 
procedure TBoundedBuffer.ResetState;
 

{ Cierra los manejadores y libera la memoria.

Ntese que aqu se deben desbloquear los hilos de manera tal que puedan

terminar limpiamente. }

 
begin
 if FBufInit then
 begin
 WaitForSingleObject(FCriticalMutex, DefaultWaitTime);
 FBufInit := false;
 FBufSize := 0;
 FreeMem(FBuf);
 ReleaseSemaphore(FEntriesUsed, 1, nil);
 ReleaseSemaphore(FEntriesFree, 1, nil);
 CloseHandle(FEntriesFree);
 CloseHandle(FEntriesUsed);
 ReleaseMutex(FCriticalMutex);
 CloseHandle(FCriticalMutex);
 end;
end;
 
function TBoundedBuffer.ControlledWait(Semaphore: THandle): boolean;
 
var
 ErrCode: integer;
 
begin
 repeat
 ErrCode := WaitForSingleObject(Semaphore, DefaultWaitTime);
 if (ErrCode = WAIT_OBJECT_0) or (ErrCode = WAIT_ABANDONED) then
 begin

{ Si la espera fue abandonada, devuelve el error. El buffer no

se limpio adecuadamente }

 result := ErrCode = WAIT_OBJECT_0;
 exit;
 end;

{ La espera dio time out. Verifica que el buffer haya sido inicializado }

 if WaitForSingleObject(FCriticalMutex, DefaultWaitTime) <> WAIT_OBJECT_0 then
 begin
 result := false;
 exit;
 end
 else
 begin
 result := FBufInit;
 ReleaseMutex(FCriticalMutex);
 end;
 until not Result;
end;
 
function TBoundedBuffer.PutItem(NewItem: Pointer): boolean;
 
{ Llamado por el buffer productor }
var
 NthItem: TBufferEntries;
 
begin
 result := false;
 { ESPERA(EntriesFree) }
 if not ControlledWait(FEntriesFree) then
 exit;
 if (WaitForSingleObject(FCriticalMutex, DefaultWaitTime) <> WAIT_OBJECT_0)
 or not FBufInit then { NB.Esta condicin depende de la evaluacin L -> R }
 exit;
 NthItem := FBuf;
 Inc(NthItem, FWritePtr);
 NthItem^ := NewItem;
 FWritePtr := (FWritePtr + 1) mod FBufSize;
 Inc(FEntryCountUsed);
 Dec(FEntryCountFree);
 ReleaseMutex(FCriticalMutex);
 { MARCA(EntriesUsed) }
 ReleaseSemaphore(FEntriesUsed, 1, nil);
 result := true;
end;
 
function TBoundedBuffer.GetItem: Pointer;
 
{ Llamado por el hilo consumidor }
var
 NthItem: TBufferEntries;
 
begin
 result := nil;
 { ESPERA(EntriesUsed) }
 if not ControlledWait(FEntriesUsed) then
 exit;
 if (WaitForSingleObject(FCriticalMutex, DefaultWaitTime) <> WAIT_OBJECT_0)
 or not FBufInit then { NB.Esta condicin depende de la evaluacin L -> R }
 exit;
 NthItem := FBuf;
 Inc(NthItem, FReadPtr);
 Result := NthItem^;
 FReadPtr := (FReadPtr + 1) mod FBufSize;
 Inc(FEntryCountFree);
 Dec(FEntryCountUsed);
 ReleaseMutex(FCriticalMutex);
 { MARCA(EntriesFree) }
 ReleaseSemaphore(FEntriesFree, 1, nil);
end;
 
destructor TBoundedBuffer.Destroy;
begin
 ResetState;
 inherited Destroy;
end;
 
function TBoundedBuffer.GetEntriesFree(var Free: integer): boolean;
begin
 result := false;
 if (WaitForSingleObject(FCriticalMutex, DefaultWaitTime) <> WAIT_OBJECT_0)
 or not FBufInit then
 exit;
 Free := FEntryCountFree;
 result := true;
 ReleaseMutex(FCriticalMutex);
end;
 
function TBoundedBuffer.GetEntriesUsed(var Used: integer): boolean;
begin
 result := false;
 if (WaitForSingleObject(FCriticalMutex, DefaultWaitTime) <> WAIT_OBJECT_0)
 or not FBufInit then
 exit;
 Used := FEntryCountUsed;
 result := true;
 ReleaseMutex(FCriticalMutex);
end;
 
end.