Sample 1

unit test;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls;

type

  TForm1 = class(TForm)
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
  private
{ Private declarations }
  public
{ Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.Button1Click(Sender: TObject);
begin
  ShowMessage('Hello World!');
end;

end.





Sample 2



unit PrimeForm;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls;

type
  TPrimeFrm = class(TForm)
    NumEdit: TEdit;
    SpawnButton: TButton;
    procedure SpawnButtonClick(Sender: TObject);
  private
{ Private declarations }
  public
{ Public declarations }
  end;

var
  PrimeFrm: TPrimeFrm;

implementation

uses PrimeThread;

{$R *.DFM}

procedure TPrimeFrm.SpawnButtonClick(Sender: TObject);

var
  NewThread: TPrimeThrd;

begin
  NewThread := TPrimeThrd.Create(True);
  NewThread.FreeOnTerminate := True;
  try
    NewThread.TestNumber := StrToInt(NumEdit.Text);
    NewThread.Resume;
  except on EConvertError do
    begin
      NewThread.Free;
      ShowMessage('That is not a valid number!');
    end;
  end;
end;

end.



Sample 3

unit PrimeThread;

interface

uses
  Classes;

type
  TPrimeThrd = class(TThread)
  private
    FTestNumber: integer;
  protected
    function IsPrime: boolean;
    procedure Execute; override;
  public
    property TestNumber: integer write FTestNumber;
  end;

implementation

uses SysUtils, Dialogs;

function TPrimeThrd.IsPrime: boolean;

var
  iter: integer;

begin
  result := true;
  if FTestNumber < 0 then
  begin
    result := false;
    exit;
  end;
  if FTestNumber <= 2 then
    exit;
  for iter := 2 to FTestNumber - 1 do
  begin
    if (FTestNumber mod iter) = 0 then
    begin
      result := false;
{exit;}
    end;
  end;
end;

procedure TPrimeThrd.Execute;
begin
  if IsPrime then
    ShowMessage(IntToStr(FTestNumber) + 'is prime.')
  else
    ShowMessage(IntToStr(FTestNumber) + 'is not prime.');
end;

end.




Sample 4

var
  a: integer; {a is global}

begin
  a := a + 1;
end;



Sample 5

type
  TPrimeFrm = class(TForm)
    NumEdit: TEdit;
    SpawnButton: TButton;
    ResultsMemo: TMemo;
    procedure SpawnButtonClick(Sender: TObject);
  private
{ Private declarations }
  public
{ Public declarations }
  end;






Sample 6

unit PrimeThread;

interface

uses
  Classes;

type
  TPrimeThrd = class(TThread)
  private
    FTestNumber: integer;
    FResultString: string;
  protected
    function IsPrime: boolean;
    procedure UpdateResults;
    procedure Execute; override;
  public
    property TestNumber: integer write FTestNumber;
  end;

implementation

uses SysUtils, Dialogs, PrimeForm;

procedure TPrimeThrd.UpdateResults;
begin
  PrimeFrm.ResultsMemo.Lines.Add(FResultString);
end;

function TPrimeThrd.IsPrime: boolean; {omitted for brevity}

  procedure TPrimeThrd.Execute;
  begin
    if IsPrime then
      FResultString := IntToStr(FTestNumber) + ' is prime.'
    else
      FResultString := IntToStr(FTestNumber) + ' is not prime.';
    Synchronize(UpdateResults);
  end;

end.




Sample 7

function TPrimeThrd.IsPrime: boolean;

var
  iter: integer;

begin
  result := true;
  if FTestNumber < 0 then
  begin
    result := false;
    exit;
  end;
  if FTestNumber <= 2 then
    exit;
  iter := 2;
  while (iter < FTestNumber) and (not terminated) do
  begin
    if (FTestNumber mod iter) = 0 then
    begin
      result := false;
{exit;}
    end;
    Inc(iter);
  end;
end;




Sample 8

unit PrimeForm;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls;

type
  TPrimeFrm = class(TForm)
    NumEdit: TEdit;
    SpawnButton: TButton;
    ResultsMemo: TMemo;
    procedure SpawnButtonClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
  private
{ Private declarations }
    FThreadRefCount: integer;
    procedure HandleTerminate(Sender: TObject);
  public
{ Public declarations }
  end;

var
  PrimeFrm: TPrimeFrm;

implementation

uses PrimeThread;

{$R *.DFM}

procedure TPrimeFrm.SpawnButtonClick(Sender: TObject);

var
  NewThread: TPrimeThrd;

begin
  NewThread := TPrimeThrd.Create(True);
  NewThread.FreeOnTerminate := True;
  try
    with NewThread do
    begin
      TestNumber := StrToInt(NumEdit.Text);
      Inc(FThreadRefCount);
      OnTerminate := HandleTerminate;
      Resume;
    end;
  except on EConvertError do
    begin
      NewThread.Free;
      ShowMessage('That is not a valid number!');
    end;
  end;
end;

procedure TPrimeFrm.FormCreate(Sender: TObject);
begin
  FThreadRefCount := 0;
end;

procedure TPrimeFrm.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
begin
  CanClose := true;
  if FThreadRefCount > 0 then
  begin
    if MessageDlg('Threads active. Do you still want to quit?',
      mtWarning, [mbYes, mbNo], 0) = mrNo then
      CanClose := false;
  end;
end;

procedure TPrimeFrm.HandleTerminate(Sender: TObject);
begin
  Dec(FThreadRefCount);
end;

end.




Sample 9

unit PrimeForm;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, PrimeThread;

const
  WM_THREAD_COMPLETE = WM_APP + 5437; { Just a magic number }

type
  TPrimeFrm = class(TForm)
    NumEdit: TEdit;
    SpawnButton: TButton;
    ResultsMemo: TMemo;
    procedure SpawnButtonClick(Sender: TObject);
    procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
  private
{ Private declarations }
    FThread: TPrimeThrd;
    procedure HandleThreadCompletion(var Message: TMessage); message WM_THREAD_COMPLETE;
  public
{ Public declarations }
  end;

var
  PrimeFrm: TPrimeFrm;

implementation

{$R *.DFM}

procedure TPrimeFrm.HandleThreadCompletion(var Message: TMessage);
begin
  if Assigned(FThread) then
  begin
    FThread.WaitFor;
    FThread.Free;
    FThread := nil;
  end;
end;

procedure TPrimeFrm.SpawnButtonClick(Sender: TObject);

begin
  if not Assigned(FThread) then
  begin
    FThread := TPrimeThrd.Create(True);
    FThread.FreeOnTerminate := false;
    try
      with FThread do
      begin
        TestNumber := StrToInt(NumEdit.Text);
        Resume;
      end;
    except on EConvertError do
      begin
        FThread.Free;
        FThread := nil;
        ShowMessage('That is not a valid number!');
      end;
    end;
  end;
end;

procedure TPrimeFrm.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
begin
  CanClose := true;
  if Assigned(FThread) then
  begin
    if MessageDlg('Threads active. Do you still want to quit?',
      mtWarning, [mbYes, mbNo], 0) = mrNo then
      CanClose := false;
  end;
{Sleep(50000);}{Line C}
  if CanClose then
  begin
    if Assigned(FThread) then
    begin
      FThread.Terminate;
      FThread.WaitFor;
      FThread.Free;
      FThread := nil;
    end;
  end;
end;

end.




Sample 10

unit PrimeThread;

interface

uses
  Classes;

type
  TPrimeThrd = class(TThread)
  private
    FTestNumber: integer;
    FResultString: string;
  protected
    function IsPrime: boolean;
    procedure UpdateResults;
    procedure Execute; override;
  public
    property TestNumber: integer write FTestNumber;
  end;

implementation

uses SysUtils, Dialogs, PrimeForm, Windows;

procedure TPrimeThrd.UpdateResults;
begin
  PrimeFrm.ResultsMemo.Lines.Add(FResultString);
end;

function TPrimeThrd.IsPrime: boolean;

var
  iter: integer;

begin
  result := true;
  if FTestNumber < 0 then
  begin
    result := false;
    exit;
  end;
  if FTestNumber <= 2 then
    exit;
  iter := 2;
  while (iter < FTestNumber) and (not terminated) do {Line A}
  begin
    if (FTestNumber mod iter) = 0 then
    begin
      result := false;
{exit;}
    end;
    Inc(iter);
  end;
end;

procedure TPrimeThrd.Execute;
begin
  if IsPrime then
    FResultString := IntToStr(FTestNumber) + ' is prime.'
  else
    FResultString := IntToStr(FTestNumber) + ' is not prime.';
  if not Terminated then {Line B}
  begin
    Synchronize(UpdateResults);
    PostMessage(PrimeFrm.Handle, WM_THREAD_COMPLETE, 0, 0);
  end;
end;

end.




Sample 11

{ Unit PrimeThread }

type
  TPrimeThrd = class(TThread)
  private
    FTestNumber: integer;
    FResultString: string;
  protected
    function IsPrime: boolean;
    procedure Execute; override;
  public
    property TestNumber: integer write FTestNumber;
    property ResultString: string read FResultString;
  end;

procedure TPrimeThrd.Execute;
begin
  if IsPrime then
    FResultString := IntToStr(FTestNumber) + ' is prime.'
  else
    FResultString := IntToStr(FTestNumber) + ' is not prime.';
  if not Terminated then {Line B}
    PostMessage(PrimeFrm.Handle, WM_THREAD_COMPLETE, 0, 0);
end;

{ Unit PrimeForm }

procedure TPrimeFrm.HandleThreadCompletion(var Message: TMessage);
begin
  if Assigned(FThread) then
  begin
    FThread.WaitFor;
    ResultsMemo.Lines.Add(FThread.ResultString);
    FThread.Free;
    FThread := nil;
  end;
end;




Sample 12

unit PrimeForm2;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, PrimeThread;

const
  WM_DATA_IN_BUF = WM_APP + 1000;
  MaxMemoLines = 20;

type
  TPrimeFrm = class(TForm)
    ResultMemo: TMemo;
    StartBtn: TButton;
    StartNumEdit: TEdit;
    StopBtn: TButton;
    procedure StartBtnClick(Sender: TObject);
    procedure StopBtnClick(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
  private
{ Private declarations }
    FStringSectInit: boolean;
    FPrimeThread: TPrimeThrd2;
    FStringBuf: TStringList;
    procedure UpdateButtons;
    procedure HandleNewData(var Message: TMessage); message WM_DATA_IN_BUF;
  public
{ Public declarations }
    StringSection: TRTLCriticalSection;
    property StringBuf: TStringList read FStringBuf write FStringBuf;
  end;

var
  PrimeFrm: TPrimeFrm;

implementation

{$R *.DFM}

procedure TPrimeFrm.UpdateButtons;
begin
  StopBtn.Enabled := FStringSectInit;
  StartBtn.Enabled := not FStringSectInit;
end;

procedure TPrimeFrm.StartBtnClick(Sender: TObject);
begin
  if not FStringSectInit then
  begin
    InitializeCriticalSection(StringSection);
    FStringBuf := TStringList.Create;
    FStringSectInit := true;
    FPrimeThread := TPrimeThrd2.Create(true);
    SetThreadPriority(FPrimeThread.Handle, THREAD_PRIORITY_BELOW_NORMAL);
    try
      FPrimeThread.StartNum := StrToInt(StartNumEdit.Text);
    except
      on EConvertError do FPrimeThread.StartNum := 2;
    end;
    FPrimeThread.Resume;
  end;
  UpdateButtons;
end;

procedure TPrimeFrm.StopBtnClick(Sender: TObject);
begin
  if FStringSectInit then
  begin
    with FPrimeThread do
    begin
      Terminate;
      WaitFor;
      Free;
    end;
    FPrimeThread := nil;
    FStringBuf.Free;
    FStringBuf := nil;
    DeleteCriticalSection(StringSection);
    FStringSectInit := false;
  end;
  UpdateButtons;
end;

procedure TPrimeFrm.HandleNewData(var Message: TMessage);
begin
  if FStringSectInit then {Not necessarily the case!}
  begin
    EnterCriticalSection(StringSection);
    ResultMemo.Lines.Add(FStringBuf.Strings[0]);
    FStringBuf.Delete(0);
    LeaveCriticalSection(StringSection);
{Now trim the Result Memo.}
    if ResultMemo.Lines.Count > MaxMemoLines then
      ResultMemo.Lines.Delete(0);
  end;
end;

procedure TPrimeFrm.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  StopBtnClick(Self);
end;

end.




Sample 13

unit PrimeThread;

interface

uses
  Classes, Windows;

type
  TPrimeThrd2 = class(TThread)
  private
{ Private declarations }
    FStartNum: integer;
    function IsPrime(TestNo: integer): boolean;
  protected
    procedure Execute; override;
  public
    property StartNum: integer read FStartNum write FStartNum;
  end;

implementation

uses PrimeForm2, SysUtils;

function TPrimeThrd2.IsPrime(TestNo: integer): boolean;

var
  iter: integer;

begin
  result := true;
  if TestNo < 0 then
    result := false;
  if TestNo <= 2 then
    exit;
  iter := 2;
  while (iter < TestNo) and (not terminated) do
  begin
    if (TestNo mod iter) = 0 then
    begin
      result := false;
      exit;
    end;
    Inc(iter);
  end;
end;

procedure TPrimeThrd2.Execute;

var
  CurrentNum: integer;

begin
  CurrentNum := FStartNum;
  while not Terminated do
  begin
    if IsPrime(CurrentNum) then
    begin
      EnterCriticalSection(PrimeFrm.StringSection);
      PrimeFrm.StringBuf.Add(IntToStr(CurrentNum) + ' is prime.');
      LeaveCriticalSection(PrimeFrm.StringSection);
      PostMessage(PrimeFrm.Handle, WM_DATA_IN_BUF, 0, 0);
    end;
    Inc(CurrentNum);
  end;
end;

end.




Sample 14

function Read(L: TList; Index: integer): integer;
begin
  if (Index > 0) and (L.Count > Index) then
  begin
    with L.Items[Index] do
    begin
      Lock;
      Result := Value;
      Unlock;
    end;
  end
  else
    raise ENotFound;
end;

procedure Write(L: TList; Index: integer; NewVal: integer);
begin
  if (Index > 0) and (L.Count > Index) then
  begin
    with L.Items[Index] do
    begin
      Lock;
      Value := NewVal;
      Unlock;
    end;
  end
  else
    raise ENotFound;
end;

function Compare(L: TList; Ind1, Ind2: integer): integer;
begin
  if (Ind1 > 0) and (Ind2 > 0) and (L.Count > Ind1) and (L.Count > Ind2) then
  begin
    L.Items[Ind1].Lock;
    L.Items[Ind2}.Lock;
      Result := L.Items[Ind2].Value - L.Items[Ind1].Value;
      L.Items[Ind2].Unlock;
      L.Items[Ind1].Unlock;
  end
  else
    raise ENotFound;
end;




Sample 15

function CompareIndirect(L: TList; Ind1: integer): integer;
var
  Ind2: integer;

begin
  if (Ind1 > 0) and (L.Count > Ind1) then
  begin
    L.Items[Ind1].Lock;
    Ind2 := L.Items[Ind1];
    Assert(Ind2 <> Ind1); {I'm not even going to consider this nasty case in any more detail!}
    if Ind2 > Ind1 then
      L.Items[Ind2].Lock
    else
    begin
      L.Items[Ind1].Unlock;
      L.Items[Ind2].Lock;
      L.Items[Ind1].Lock;
    end;
    Result := L.Items[Ind2].Value - L.Items[Ind1].Value;
    L.Items[Ind1].Unlock;
    L.Items[Ind2].Unlock;
  end
  else
    raise ENotFound;
end;




Sample 16

function CompareIndirect(L: TList; Ind1: integer): integer;
var
  Ind2: integer;
  TempValue: integer;

begin
  if (Ind1 > 0) and (L.Count > Ind1) then
  begin
    L.Items[Ind1].Lock;
    Ind2 := L.Items[Ind1];
    Assert(Ind2 <> Ind1); {I'm not even going to consider this nasty case in any more detail!}
    if Ind2 > Ind1 then
      L.Items[Ind2].Lock
    else
    begin
      TempValue := L.Items[Ind1].Value;
      L.Items[Ind1].Unlock;
      L.Items[Ind2].Lock;
      L.Items[Ind1].Lock;
    end;
    if TempValue := L.Items[Ind1].Value then
      Result := L.Items[Ind2].Value - L.Items[Ind1].Value
    else
{Perhaps some retry mechanism?};
    L.Items[Ind1].Unlock;
    L.Items[Ind2].Unlock;
  end
  else
    raise ENotFound;
end;




Sample 17

type
  TPrimeFrm = class(TForm)
{ No change here until public declarations }
  public
{ Public declarations }
    StringSemaphore: THandle; { Now a semaphore instead of a critical section }
    property StringBuf: TStringList read FStringBuf write FStringBuf;
  end;

procedure TPrimeFrm.StartBtnClick(Sender: TObject);
begin
  if not FStringSectInit then
  begin
    StringSemaphore := CreateSemaphore(nil, 1, 1, SemName); { Now creating a semaphore instead of a critical section }
    FStringBuf := TStringList.Create;
    FStringSectInit := true;
    FPrimeThread := TPrimeThrd2.Create(true);
    SetThreadPriority(FPrimeThread.Handle, THREAD_PRIORITY_BELOW_NORMAL);
    try
      FPrimeThread.StartNum := StrToInt(StartNumEdit.Text);
    except
      on EConvertError do FPrimeThread.StartNum := 2;
    end;
    FPrimeThread.Resume;
  end;
  UpdateButtons;
end;

procedure TPrimeFrm.StopBtnClick(Sender: TObject);
begin
  if FStringSectInit then
  begin
    with FPrimeThread do
    begin
      Terminate;
      WaitFor;
      Free;
    end;
    FPrimeThread := nil;
    FStringBuf.Free;
    FStringBuf := nil;
    CloseHandle(StringSemaphore); { Deleting semaphore }
    FStringSectInit := false;
  end;
  UpdateButtons;
end;

procedure TPrimeFrm.HandleNewData(var Message: TMessage);
begin
  if FStringSectInit then {Not necessarily the case!}
  begin
    WaitForSingleObject(StringSemaphore, INFINITE); { New wait call }
    ResultMemo.Lines.Add(FStringBuf.Strings[0]);
    FStringBuf.Delete(0);
    ReleaseSemaphore(StringSemaphore, 1, nil); { New release call }
{Now trim the Result Memo.}
    if ResultMemo.Lines.Count > MaxMemoLines then
      ResultMemo.Lines.Delete(0);
  end;
end;

procedure TPrimeThrd2.Execute;

var
  CurrentNum: integer;

begin
  CurrentNum := FStartNum;
  while not Terminated do
  begin
    if IsPrime(CurrentNum) then
    begin
      WaitForSingleObject(PrimeFrm.StringSemaphore, INFINITE); { New wait call }
      PrimeFrm.StringBuf.Add(IntToStr(CurrentNum) + ' is prime.');
      ReleaseSemaphore(PrimeFrm.StringSemaphore, 1, nil); { New release call }
      PostMessage(PrimeFrm.Handle, WM_DATA_IN_BUF, 0, 0);
    end;
    Inc(CurrentNum);
  end;
end;




Sample 18

unit BoundedBuf;

{Martin Harvey 24/4/2000}

interface

uses Windows, SysUtils;

const
  DefaultWaitTime = 5000; { Five second wait on mutexes }

type
{ I don't particularly like dynamic arrays, so I'm going to do things
the "C" way here, explicitly allocating memory
Think of TBufferEntries as ^(array of pointer) }

  TBufferEntries = ^Pointer;

  TBoundedBuffer = class
  private
    FBufInit: boolean;
    FBufSize: integer;
    FBuf: TBufferEntries;
    FReadPtr, { ReadPtr points to next used entry in buffer}
      FWritePtr: integer; { WritePtr points to next free entry in buffer}
    FEntriesFree, FEntriesUsed: THandle; { Flow control semaphores }
    FCriticalMutex: THandle; { Critical section mutex }
  protected
    procedure SetSize(NewSize: integer);
  public
    procedure ResetState;
    destructor Destroy; override;
    function PutItem(NewItem: Pointer): boolean;
    function GetItem: Pointer;
  published
    property Size: integer read FBufSize write SetSize;
  end;

{ No constructor required because default values of 0, false etc acceptable }

implementation

const
  FailMsg1 = 'Flow control failed, or buffer not initialised';
  FailMsg2 = 'Critical section failed, or buffer not initialised';

procedure TBoundedBuffer.SetSize(NewSize: integer);

{ Initialises handles and allocates memory.
If the buffer size has previously been set, then this may invoke a buffer
reset }

begin
  if FBufInit then ResetState;
  if NewSize < 2 then NewSize := 2;
  FBufSize := NewSize;
  GetMem(FBuf, Sizeof(Pointer) * FBufSize);
  FillMemory(FBuf, Sizeof(Pointer) * FBufSize, 0);
  FBufInit := true;
  FCriticalMutex := CreateMutex(nil, false, nil); { note lack of name }
{ The initial count on the semaphores requires some thought,
The maximum count requires more thought.
Again, all synchronisation objects are anonymous }
  FEntriesFree := CreateSemaphore(nil, FBufSize - 1, FBufSize, nil);
  FEntriesUsed := CreateSemaphore(nil, 0, FBufSize, nil);
  if (FCriticalMutex = 0)
    or (FEntriesFree = 0)
    or (FEntriesUsed = 0) then ResetState
end;

procedure TBoundedBuffer.ResetState;

{ Closes handles and deallocates memory.
Note that this must unblock threads in such a manner that they quit cleanly }

begin
  if FBufInit then
  begin
    WaitForSingleObject(FCriticalMutex, DefaultWaitTime);
    FBufInit := false;
    FBufSize := 0;
    FreeMem(FBuf);
{ Now wake up all threads currently waiting.
Currently assumes only 1 producer and 1 consumer.
Plenty of ordering subtleties and pitfalls to be discussed here }
    ReleaseSemaphore(FEntriesFree, 1, nil);
    ReleaseSemaphore(FEntriesUsed, 1, nil);
    CloseHandle(FEntriesFree);
    CloseHandle(FEntriesUsed);
{ If reader or writer threads are waiting,
then they will be waiting on the mutex.
We will close the handle and let them time out }
    CloseHandle(FCriticalMutex);
  end;
end;

function TBoundedBuffer.PutItem(NewItem: Pointer): boolean;

{ Called by producer thread }
var
  NthItem: TBufferEntries;

begin
  result := false;
{ WAIT(EntriesFree) }
  if WaitForSingleObject(FEntriesFree, INFINITE) <> WAIT_OBJECT_0 then
    exit;
  if (WaitForSingleObject(FCriticalMutex, DefaultWaitTime) <> WAIT_OBJECT_0)
    or not FBufInit then
    exit;
  NthItem := FBuf;
  Inc(NthItem, FWritePtr);
  NthItem^ := NewItem;
  FWritePtr := (FWritePtr + 1) mod FBufSize;
  ReleaseMutex(FCriticalMutex);
{ SIGNAL(EntriesUsed) }
  ReleaseSemaphore(FEntriesUsed, 1, nil);
  result := true;
end;

function TBoundedBuffer.GetItem: Pointer;

{ Called by consumer thread }
var
  NthItem: TBufferEntries;

begin
  result := nil;
{ WAIT(EntriesUsed) }
  if WaitForSingleObject(FEntriesUsed, INFINITE) <> WAIT_OBJECT_0 then
    exit;
  if (WaitForSingleObject(FCriticalMutex, DefaultWaitTime) <> WAIT_OBJECT_0)
    or not FBufInit then
    exit;
  NthItem := FBuf;
  Inc(NthItem, FReadPtr);
  Result := NthItem^;
  FReadPtr := (FReadPtr + 1) mod FBufSize;
  ReleaseMutex(FCriticalMutex);
{ SIGNAL(EntriesFree) }
  ReleaseSemaphore(FEntriesFree, 1, nil);
end;

destructor TBoundedBuffer.Destroy;
begin
  ResetState;
  inherited Destroy;
end;

end.




Sample 19

procedure TBoundedBuffer.ResetState;

{ Closes handles and deallocates memory.
Note that this must unblock threads in such a manner that they quit cleanly }

var
  SemCount: integer;

begin
  if FBufInit then
  begin
    WaitForSingleObject(FCriticalMutex, DefaultWaitTime);
    FBufInit := false;
    FBufSize := 0;
    FreeMem(FBuf);
    repeat
      ReleaseSemaphore(FEntriesFree, 1, @SemCount);
    until SemCount = 0;
    repeat
      ReleaseSemaphore(FEntriesUsed, 1, @SemCount);
    until SemCount = 0;
    CloseHandle(FEntriesFree);
    CloseHandle(FEntriesUsed);
    CloseHandle(FCriticalMutex);
  end;
end;




Sample 20

procedure TBoundedBuffer.ResetState;

{ Closes handles and deallocates memory.
Note that this must unblock threads in such a manner that they quit cleanly }

var
  SemCount: integer;
  LocalHandle: THandle;

begin
  if FBufInit then
  begin
    WaitForSingleObject(FCriticalMutex, DefaultWaitTime);
    FBufInit := false;
    FBufSize := 0;
    FreeMem(FBuf);
    LocalHandle := FEntriesFree;
    FEntriesFree := 0;
    repeat
      ReleaseSemaphore(LocalHandle, 1, @SemCount);
    until SemCount = 0;
    CloseHandle(LocalHandle);
    LocalHandle := FEntriesUsed;
    FEntriesUsed := 0;
    repeat
      ReleaseSemaphore(LocalHandle, 1, @SemCount);
    until SemCount = 0;
    CloseHandle(LocalHandle);
    CloseHandle(FCriticalMutex);
  end;
end;




Sample 21

unit HandleForm;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls;

type
  THandleFrm = class(TForm)
    CreateBtn: TButton;
    CloseOwnerBtn: TButton;
    CloseNonOwnerBtn: TButton;
    procedure CreateBtnClick(Sender: TObject);
    procedure CloseOwnerBtnClick(Sender: TObject);
    procedure CloseNonOwnerBtnClick(Sender: TObject);
  private
{ Private declarations }
  public
{ Public declarations }
    Mutex: THandle;
  end;

var
  HandleFrm: THandleFrm;

implementation

uses HandleThreads;

{$R *.DFM}

procedure THandleFrm.CreateBtnClick(Sender: TObject);

var
  NewThread: THandleThread;

begin
  Mutex := CreateMutex(nil, false, nil);
  WaitForSingleObject(Mutex, INFINITE);
  NewThread := THandleThread.Create(false);
  NewThread := THandleThread.Create(false);
  ShowMessage('Threads Created.');
end;

procedure THandleFrm.CloseOwnerBtnClick(Sender: TObject);
begin
  CloseHandle(Mutex);
end;

procedure THandleFrm.CloseNonOwnerBtnClick(Sender: TObject);
begin
  ReleaseMutex(Mutex);
  CloseHandle(Mutex);
end;

end.

unit HandleThreads;

interface

uses
  Classes, Windows, SysUtils, Dialogs;

type
  THandleThread = class(TThread)
  private
{ Private declarations }
  protected
    procedure Execute; override;
  end;

implementation

uses HandleForm;

procedure THandleThread.Execute;

var
  RetVal: integer;

begin
  RetVal := WaitForSingleObject(HandleFrm.Mutex, INFINITE);
  case RetVal of
    WAIT_OBJECT_0: ShowMessage('Unblocked: WAIT_OBJECT_0');
    WAIT_ABANDONED: ShowMessage('Unblocked: WAIT_ABANDONED');
    WAIT_TIMEOUT: ShowMessage('Unblocked: WAIT_TIMEOUT');
  else
    ShowMessage('Unblocked. Unknown return code.');
  end;
end;

end.




Sample 22

unit HandleForm;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls;

type
  THandleFrm = class(TForm)
    CreateBtn: TButton;
    CloseOwnerBtn: TButton;
    CloseNonOwnerBtn: TButton;
    RelBtn: TButton;
    procedure CreateBtnClick(Sender: TObject);
    procedure CloseOwnerBtnClick(Sender: TObject);
    procedure CloseNonOwnerBtnClick(Sender: TObject);
    procedure RelBtnClick(Sender: TObject);
  private
{ Private declarations }
  public
{ Public declarations }
    Semaphore: THandle;
  end;

var
  HandleFrm: THandleFrm;

implementation

uses HandleThreads;

{$R *.DFM}

procedure THandleFrm.CreateBtnClick(Sender: TObject);

begin
  Semaphore := CreateSemaphore(nil, 1, 1, nil);
  WaitForSingleObject(Semaphore, INFINITE);
  THandleThread.Create(false);
  THandleThread.Create(false);
  ShowMessage('Threads Created.');
end;

procedure THandleFrm.CloseOwnerBtnClick(Sender: TObject);
begin
  CloseHandle(Semaphore);
end;

procedure THandleFrm.CloseNonOwnerBtnClick(Sender: TObject);
begin
  ReleaseSemaphore(Semaphore, 1, nil);
  CloseHandle(Semaphore);
end;

procedure THandleFrm.RelBtnClick(Sender: TObject);
begin
  ReleaseSemaphore(Semaphore, 1, nil);
end;

end.

unit HandleThreads;

interface

uses
  Classes, Windows, SysUtils, Dialogs;

type
  THandleThread = class(TThread)
  private
{ Private declarations }
  protected
    procedure Execute; override;
  end;

implementation

uses HandleForm;

procedure THandleThread.Execute;

var
  RetVal: integer;

begin
  RetVal := WaitForSingleObject(HandleFrm.Semaphore, 10000);
  case RetVal of
    WAIT_OBJECT_0: ShowMessage('Unblocked: WAIT_OBJECT_0');
    WAIT_ABANDONED: ShowMessage('Unblocked: WAIT_ABANDONED');
    WAIT_TIMEOUT: ShowMessage('Unblocked: WAIT_TIMEOUT');
  else
    ShowMessage('Unblocked. Unknown return code.');
  end;
end;

end.




Sample 23

unit BoundedBuf;

{Martin Harvey 24/4/2000}

interface

uses Windows, SysUtils;

const
  DefaultWaitTime = 1000; { One second wait on all synchronisation primitives }

type
{ I don't particularly like dynamic arrays, so I'm going to do things
the "C" way here, explicitly allocating memory
Think of TBufferEntries as ^(array of pointer) }

  TBufferEntries = ^Pointer;

  TBoundedBuffer = class
  private
    FBufInit: boolean;
    FBufSize: integer;
    FBuf: TBufferEntries;
    FReadPtr, { ReadPtr points to next used entry in buffer}
      FWritePtr: integer; { WritePtr points to next free entry in buffer}
    FEntriesFree, FEntriesUsed: THandle; { Flow control semaphores }
    FCriticalMutex: THandle; { Critical section mutex }
  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;
  published
    property Size: integer read FBufSize write SetSize;
  end;

{ No constructor required because default values of 0, false etc acceptable }

implementation

procedure TBoundedBuffer.SetSize(NewSize: integer);

{ Initialises handles and allocates memory.
If the buffer size has previously been set, then this may invoke a buffer
reset }

begin
  if FBufInit then ResetState;
  if NewSize < 2 then NewSize := 2;
  FBufSize := NewSize;
  GetMem(FBuf, Sizeof(Pointer) * FBufSize);
  FillMemory(FBuf, Sizeof(Pointer) * FBufSize, 0);
  FBufInit := true;
  FCriticalMutex := CreateMutex(nil, false, nil); { note lack of name }
{ The initial count on the semaphores requires some thought,
The maximum count requires more thought.
Again, all synchronisation objects are anonymous }
  FEntriesFree := CreateSemaphore(nil, FBufSize - 1, FBufSize, nil);
  FEntriesUsed := CreateSemaphore(nil, 0, FBufSize, nil);
  if (FCriticalMutex = 0)
    or (FEntriesFree = 0)
    or (FEntriesUsed = 0) then ResetState
end;

procedure TBoundedBuffer.ResetState;

{ Closes handles and deallocates memory.
Note that this must unblock threads in such a manner that they quit cleanly }

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
{ If wait abandoned, return failure. Buffer not properly cleaned up }
      result := ErrCode = WAIT_OBJECT_0;
      exit;
    end;
{ Wait timed out. Check whether buffer state initialised }
    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;

{ Called by producer thread }
var
  NthItem: TBufferEntries;

begin
  result := false;
{ WAIT(EntriesFree) }
  if not ControlledWait(FEntriesFree) then
    exit;
  if (WaitForSingleObject(FCriticalMutex, DefaultWaitTime) <> WAIT_OBJECT_0)
    or not FBufInit then { NB.This condition depends on L -> R lazy evaluation }
    exit;
  NthItem := FBuf;
  Inc(NthItem, FWritePtr);
  NthItem^ := NewItem;
  FWritePtr := (FWritePtr + 1) mod FBufSize;
  ReleaseMutex(FCriticalMutex);
{ SIGNAL(EntriesUsed) }
  ReleaseSemaphore(FEntriesUsed, 1, nil);
  result := true;
end;

function TBoundedBuffer.GetItem: Pointer;

{ Called by consumer thread }
var
  NthItem: TBufferEntries;

begin
  result := nil;
{ WAIT(EntriesUsed) }
  if not ControlledWait(FEntriesUsed) then
    exit;
  if (WaitForSingleObject(FCriticalMutex, DefaultWaitTime) <> WAIT_OBJECT_0)
    or not FBufInit then { NB.This condition depends on L -> R lazy evaluation }
    exit;
  NthItem := FBuf;
  Inc(NthItem, FReadPtr);
  Result := NthItem^;
  FReadPtr := (FReadPtr + 1) mod FBufSize;
  ReleaseMutex(FCriticalMutex);
{ SIGNAL(EntriesFree) }
  ReleaseSemaphore(FEntriesFree, 1, nil);
end;

destructor TBoundedBuffer.Destroy;
begin
  ResetState;
  inherited Destroy;
end;

end.




Sample 24

unit PrimeThreads;

interface

uses
  Windows, Classes, SysUtils, BoundedBuf, Forms;

type
  TIntRec = record
    Num: integer;
  end;
  PIntRec = ^TIntRec;

  TPrimeThread = class(TThread)
  private
    FBuffer: TBoundedBuffer;
  protected
    function IsPrime(TestNum: integer): boolean;
  public
    property Buffer: TBoundedBuffer read FBuffer write FBuffer;
  end;

  TForwardPrimeThread = class(TPrimeThread)
  private
  protected
    procedure SendToBackThread(TestNum: integer);
    procedure Execute; override;
  end;

  TBackwardPrimeThread = class(TPrimeThread)
  private
    FDestSection: PRTLCriticalSection;
    FDestMsgNum: integer;
    FDestForm: TForm;
    FDestList: TStrings;
  protected
    function ReverseNumber(Input: integer): integer;
    function RecieveFromForwardThread(var TestNum: integer): boolean;
    procedure SendToVCLThread(CurrentNumber, ReversedNumber: integer);
    procedure Execute; override;
  public
    property DestSection: PRTLCriticalSection read FDestSection write FDestSection;
    property DestMsgNum: integer read FDestMsgNum write FDestMsgNum;
    property DestForm: TForm read FDestForm write FDestForm;
    property DestList: TStrings read FDestList write FDestList;
  end;

var
  ForwardThread: TForwardPrimeThread;
  BackwardThread: TBackwardPrimeThread;
  Buffer: TBoundedBuffer;

procedure StartThreads(Form: TForm;
  Section: PRTLCriticalSection;
  MsgNum: integer;
  List: TStrings);
procedure StopThreads;

implementation

const
  DefBufSize = 16;

{ Ancillary procedures }

procedure StartThreads(Form: TForm;
  Section: PRTLCriticalSection;
  MsgNum: integer;
  List: TStrings);
begin
  ForwardThread := TForwardPrimeThread.Create(true);
  BackwardThread := TBackwardPrimeThread.Create(true);
  SetThreadPriority(ForwardThread.Handle, THREAD_PRIORITY_BELOW_NORMAL);
  SetThreadPriority(BackwardThread.Handle, THREAD_PRIORITY_BELOW_NORMAL);
  Buffer := TBoundedBuffer.Create;
  Buffer.Size := DefBufSize;
  ForwardThread.Buffer := Buffer;
  BackwardThread.Buffer := Buffer;
  with BackwardThread do
  begin
    DestForm := Form;
    DestSection := Section;
    DestMsgNum := MsgNum;
    DestList := List;
  end;
  ForwardThread.Resume;
  BackwardThread.Resume;
end;

procedure StopThreads;
begin
  ForwardThread.Terminate;
  BackwardThread.Terminate;
  Buffer.ResetState;
  ForwardThread.WaitFor;
  BackwardThread.WaitFor;
  Buffer.Free;
  ForwardThread.Free;
  BackwardThread.Free;
end;

{ TPrimeThread }

function TPrimeThread.IsPrime(TestNum: integer): boolean;

var
  iter: integer;

begin
  result := true;
  if TestNum < 0 then
    result := false;
  if TestNum <= 2 then
    exit;
  iter := 2;
  while (iter < TestNum) and (not terminated) do {Line A}
  begin
    if (TestNum mod iter) = 0 then
    begin
      result := false;
      exit;
    end;
    Inc(iter);
  end;
end;

{ TForwardPrimeThread }

procedure TForwardPrimeThread.SendToBackThread(TestNum: integer);

var
  NewRec: PIntRec;

begin
  New(NewRec);
  NewRec.Num := TestNum;
  if not Buffer.PutItem(NewRec) then Dispose(NewRec);
end;

procedure TForwardPrimeThread.Execute;

var
  CurrentNumber: integer;

begin
  CurrentNumber := 2;
  while not Terminated do
  begin
    if IsPrime(CurrentNumber) then
      SendToBackThread(CurrentNumber);
    Inc(CurrentNumber);
  end;
end;

{ TBackwardPrimeThread }

function TBackwardPrimeThread.RecieveFromForwardThread(var TestNum: integer): boolean;

var
  NewRec: PIntRec;

begin
  NewRec := Buffer.GetItem;
  Result := Assigned(NewRec);
  if Result then TestNum := NewRec^.Num;
end;

procedure TBackwardPrimeThread.SendToVCLThread(CurrentNumber, ReversedNumber: integer);

var
  Msg: string;

begin
  Msg := 'Palindromic primes: ' + IntToStr(CurrentNumber) + ' and '
    + IntToStr(ReversedNumber);
  EnterCriticalSection(FDestSection^);
  DestList.Add(Msg);
  LeaveCriticalSection(FDestSection^);
  PostMessage(DestForm.Handle, DestMsgNum, 0, 0);
end;

function TBackwardPrimeThread.ReverseNumber(Input: integer): integer;

var
  InStr, OutStr: string;
  Len, Iter: integer;

begin
  Input := Abs(Input);
  InStr := IntToStr(Input);
  OutStr := '';
  Len := Length(InStr);
  for Iter := Len downto 1 do
    OutStr := OutStr + InStr[Iter];
  try
    Result := StrToInt(OutStr);
  except
    on EConvertError do Result := Input;
  end;
end;

procedure TBackwardPrimeThread.Execute;

var
  CurrentNumber,
    ReversedNumber: integer;

begin
  while not Terminated do
  begin
    if RecieveFromForwardThread(CurrentNumber) then
    begin
      ReversedNumber := ReverseNumber(CurrentNumber);
      if IsPrime(ReversedNumber) then
        SendToVCLThread(CurrentNumber, ReversedNumber);
    end;
  end;
end;

end.




Sample 25

unit PalPrimeForm;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls;

const
  WM_DATA_IN_BUF = WM_APP + 1000;
  MaxMemoLines = 20;

type
  TPalFrm = class(TForm)
    ResultsMemo: TMemo;
    StartButton: TButton;
    StopButton: TButton;
    procedure StartButtonClick(Sender: TObject);
    procedure StopButtonClick(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
  private
{ Private declarations }
    FStringSectInit: boolean;
    FStringBuf: TStringList;
    StringSection: TRTLCriticalSection;
    procedure UpdateButtons;
    procedure HandleNewData(var Message: TMessage); message WM_DATA_IN_BUF;
  public
{ Public declarations }
  end;

var
  PalFrm: TPalFrm;

implementation

uses PrimeThreads;

{$R *.DFM}

procedure TPalFrm.UpdateButtons;
begin
  StopButton.Enabled := FStringSectInit;
  StartButton.Enabled := not FStringSectInit;
end;

procedure TPalFrm.StartButtonClick(Sender: TObject);
begin
  if not FStringSectInit then
  begin
    InitializeCriticalSection(StringSection);
    FStringBuf := TStringList.Create;
    FStringSectInit := true;
    StartThreads(Self, @StringSection, WM_DATA_IN_BUF, FStringBuf);
  end;
  UpdateButtons;
end;

procedure TPalFrm.StopButtonClick(Sender: TObject);
begin
  if FStringSectInit then
  begin
    ResultsMemo.Lines.Add('Please wait...');
    StopThreads;
    ResultsMemo.Lines.Add('Done!');
    FStringBuf.Free;
    FStringBuf := nil;
    DeleteCriticalSection(StringSection);
    FStringSectInit := false;
  end;
  UpdateButtons;
end;

procedure TPalFrm.HandleNewData(var Message: TMessage);
begin
  if FStringSectInit then
  begin
    EnterCriticalSection(StringSection);
    ResultsMemo.Lines.Add(FStringBuf.Strings[0]);
    FStringBuf.Delete(0);
    LeaveCriticalSection(StringSection);
    if ResultsMemo.Lines.Count > MaxMemoLines then
      ResultsMemo.Lines.Delete(0);
  end;
end;

procedure TPalFrm.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  StopButtonClick(Self);
end;

end.




Sample 26

unit BoundedBuf;

{Martin Harvey 24/4/2000}

interface

uses Windows, SysUtils;

const
  DefaultWaitTime = 1000; { One second wait on all synchronisation primitives }

type
{ I don't particularly like dynamic arrays, so I'm going to do things
the "C" way here, explicitly allocating memory
Think of TBufferEntries as ^(array of pointer) }

  TBufferEntries = ^Pointer;

  TBoundedBuffer = class
  private
    FBufInit: boolean;
    FBufSize: integer;
    FBuf: TBufferEntries;
    FReadPtr, { ReadPtr points to next used entry in buffer}
      FWritePtr: integer; { WritePtr points to next free entry in buffer}
    FEntriesFree, FEntriesUsed: THandle; { Flow control semaphores }
    FCriticalMutex: THandle; { Critical section mutex }
    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. Note that we can't use simple properties, since
we have to communicate success or failure of the operation, in addition
to providing a result }
    function GetEntriesFree(var Free: integer): boolean;
    function GetEntriesUsed(var Used: integer): boolean;
  published
    property Size: integer read FBufSize write SetSize;
  end;

{ No constructor required because default values of 0, false etc acceptable }

implementation

procedure TBoundedBuffer.SetSize(NewSize: integer);

{ Initialises handles and allocates memory.
If the buffer size has previously been set, then this may invoke a buffer
reset }

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;
{ The initial count on the semaphores requires some thought,
The maximum count requires more thought.
Again, all synchronisation objects are anonymous }
  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;

{ Closes handles and deallocates memory.
Note that this must unblock threads in such a manner that they quit cleanly }

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
{ If wait abandoned, return failure. Buffer not properly cleaned up }
      result := ErrCode = WAIT_OBJECT_0;
      exit;
    end;
{ Wait timed out. Check whether buffer state initialised }
    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;

{ Called by producer thread }
var
  NthItem: TBufferEntries;

begin
  result := false;
{ WAIT(EntriesFree) }
  if not ControlledWait(FEntriesFree) then
    exit;
  if (WaitForSingleObject(FCriticalMutex, DefaultWaitTime) <> WAIT_OBJECT_0)
    or not FBufInit then { NB.This condition depends on L -> R lazy evaluation }
    exit;
  NthItem := FBuf;
  Inc(NthItem, FWritePtr);
  NthItem^ := NewItem;
  FWritePtr := (FWritePtr + 1) mod FBufSize;
  Inc(FEntryCountUsed);
  Dec(FEntryCountFree);
  ReleaseMutex(FCriticalMutex);
{ SIGNAL(EntriesUsed) }
  ReleaseSemaphore(FEntriesUsed, 1, nil);
  result := true;
end;

function TBoundedBuffer.GetItem: Pointer;

{ Called by consumer thread }
var
  NthItem: TBufferEntries;

begin
  result := nil;
{ WAIT(EntriesUsed) }
  if not ControlledWait(FEntriesUsed) then
    exit;
  if (WaitForSingleObject(FCriticalMutex, DefaultWaitTime) <> WAIT_OBJECT_0)
    or not FBufInit then { NB.This condition depends on L -> R lazy evaluation }
    exit;
  NthItem := FBuf;
  Inc(NthItem, FReadPtr);
  Result := NthItem^;
  FReadPtr := (FReadPtr + 1) mod FBufSize;
  Inc(FEntryCountFree);
  Dec(FEntryCountUsed);
  ReleaseMutex(FCriticalMutex);
{ SIGNAL(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.





Sample 27

unit BiDirBuf;

{Martin Harvey 7/5/2000}

interface

uses BoundedBuf;

type
  TBufferSide = (bsSideA, bsSideB);
  TBufferOp = (boWriting, boReading);

  TBiDirBuf = class
  private
    FAtoBBuf, FBtoABuf: TBoundedBuffer;
  protected
    function GetBuf(Side: TBufferSide; Op: TBufferOp): TBoundedBuffer;
    function GetSize: integer;
    procedure SetSize(NewSize: integer);
  public
    constructor Create;
    destructor Destroy; override;
    procedure ResetState;
    function PutItem(Side: TBufferSide; Item: pointer): boolean;
    function GetItem(Side: TBufferSide): pointer;
{ Entries used function peeks buffer one is reading from, and
Entried free function peeks buffer one is writing to. It seems
a bit useless to allow the other two operations: why worry about
your neighbour when you have plenty else to worry about? }
    function GetEntriesUsed(Side: TBufferSide; var Used: integer): boolean;
    function GetEntriesFree(Side: TBufferSide; var Free: integer): boolean;
  published
    property Size: integer read GetSize write SetSize;
  end;

implementation

{ TBiDirBuf }

constructor TBiDirBuf.Create;
begin
  inherited Create;
  FAToBBuf := TBoundedBuffer.Create;
  FBToABuf := TBoundedBuffer.Create;
end;

destructor TBiDirBuf.Destroy;
begin
  FAToBBuf.Free;
  FBToABuf.Free;
  inherited Destroy;
end;

procedure TBiDirBuf.ResetState;
begin
  FAToBBuf.ResetState;
  FBToABuf.ResetState;
end;

function TBiDirBuf.GetBuf(Side: TBufferSide; Op: TBufferOp): TBoundedBuffer;
begin
  if ((Side = bsSideA) and (Op = boWriting))
    or ((Side = bsSideB) and (Op = boReading)) then
    result := FAToBBuf
  else if ((Side = bsSideA) and (Op = boReading))
    or ((Side = bsSideB) and (Op = boWriting)) then
    result := FBToABuf
  else
  begin
    result := FAToBBuf;
    Assert(false);
  end;
end;

function TBidirBuf.GetSize: integer;
begin
  Assert(FAToBBuf.Size = FBToABuf.Size);
  result := FAToBBuf.Size;
end;

procedure TBiDirBuf.SetSize(NewSize: integer);
begin
  FAToBBuf.Size := NewSize;
  FBToABuf.Size := NewSize;
  Assert(FAToBBuf.Size = FBToABuf.Size);
end;

function TBiDirBuf.PutItem(Side: TBufferSide; Item: Pointer): boolean;
begin
  result := GetBuf(Side, boWriting).PutItem(Item);
end;

function TBiDirBuf.GetItem(Side: TBufferSide): Pointer;
begin
  result := GetBuf(Side, boReading).GetItem;
end;

function TBiDirBuf.GetEntriesUsed(Side: TBufferSide; var Used: integer): boolean;
begin
  result := GetBuf(Side, boReading).GetEntriesUsed(Used);
end;

function TBiDirBuf.GetEntriesFree(Side: TBufferSide; var Free: integer): boolean;
begin
  result := GetBuf(Side, boWriting).GetEntriesFree(Free);
end;

end.











Sample 28

unit BlockToAsyncBuf;

{ Martin Harvey 10/5/2000 }

interface

uses Classes, Forms, Messages, Windows, BiDirBuf;

const
  InternalBufferSize = 4;
  WM_BLOCK_ASYNC = WM_USER + 2876;

type

{ With this component, as with previous buffering schemes, one cannot read
or write nil pointers. }

  TThreadNotify = (tnReaderDataFlow, tnWriterDataFlow);

  TBlockAsyncThread = class(TThread)
  private
    FDataSection: TRTLCriticalSection;
    FIdleSemaphore: THandle;
    FInterimBuf: Pointer;
    FOnDataFlow: TNotifyEvent;
    FBuffer: TBiDirBuf;
  protected
    procedure DataFlow; virtual;
    function GetItemsInTransit: integer;
  public
    constructor Create(CreateSuspended: boolean);
    destructor Destroy; override;
  published
    property OnDataFlow: TNotifyEvent read FOnDataFlow write FOnDataFlow;
    property Buffer: TBiDirBuf write FBuffer;
    property ItemsInTransit: integer read GetItemsInTransit;
  end;

  TBAWriterThread = class(TBlockAsyncThread)
  private
  protected
    procedure Execute; override;
  public
    function WriteItem(Item: Pointer): boolean;
  published
  end;

  TBAReaderThread = class(TBlockAsyncThread)
  private
  protected
    procedure Execute; override;
  public
    function ReadItem: pointer;
  published
  end;

  TBlockToAsyncBuf = class(TComponent)
  private
    FHWND: THandle;
    FBuffer: TBiDirBuf;
    FReaderThread: TBAReaderThread;
    FWriterThread: TBAWriterThread;
    FOnRead, FOnWrite: TNotifyEvent;
  protected
    procedure MessageHandler(var Msg: TMessage);
    procedure ReaderDataFlow(Sender: TObject);
    procedure WriterDataFlow(Sender: TObject);
    procedure Read; virtual;
    procedure Write; virtual;
    function GetItemsInTransit: integer;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    function BlockingRead: pointer;
    function BlockingWrite(Item: pointer): boolean;
    function AsyncRead: pointer;
    function AsyncWrite(Item: pointer): boolean;
    procedure ResetState;
  published
    property OnRead: TNotifyEvent read FOnRead write FOnRead;
    property OnWrite: TNotifyEvent read FOnWrite write FOnWrite;
    property ItemsInTransit: integer read GetItemsInTransit;
  end;

implementation

procedure TBlockAsyncThread.DataFlow;
begin
  if Assigned(FOnDataFlow) then FOnDataFlow(Self);
end;

constructor TBlockAsyncThread.Create(CreateSuspended: boolean);
begin
  inherited Create(CreateSuspended);
  InitializeCriticalSection(FDataSection);
  FIdleSemaphore := CreateSemaphore(nil, 0, High(Integer), nil);
end;

destructor TBlockAsyncThread.Destroy;
begin
  ReleaseSemaphore(FIdleSemaphore, 1, nil);
  WaitFor;
  DeleteCriticalSection(FDataSection);
  CloseHandle(FIdleSemaphore);
end;

function TBlockAsyncThread.GetItemsInTransit: integer;
begin
  EnterCriticalSection(FDataSection);
  if Assigned(FInterimBuf) then
    result := 1
  else
    result := 0;
  LeaveCriticalSection(FDataSection);
end;

{ Buffer error handling needs to be discussed }

procedure TBAWriterThread.Execute;

var
  Temp: Pointer;

begin
  while not Terminated do
  begin
    DataFlow;
    WaitForSingleObject(FIdleSemaphore, INFINITE);
    EnterCriticalSection(FDataSection);
    Temp := FInterimBuf;
    FInterimBuf := nil;
    LeaveCriticalSection(FDataSection);
    if not FBuffer.PutItem(bsSideA, Temp) then Terminate;
  end;
end;

function TBAWriterThread.WriteItem(Item: Pointer): boolean;
begin
  result := false;
  EnterCriticalSection(FDataSection);
  if not Assigned(FInterimBuf) then
  begin
    FInterimBuf := Item;
    result := true;
  end;
  LeaveCriticalSection(FDataSection);
  if Result then ReleaseSemaphore(FIdleSemaphore, 1, nil);
end;

procedure TBAReaderThread.Execute;

var
  Temp: Pointer;

begin
  while not Terminated do
  begin
    Temp := FBuffer.GetItem(bsSideA);
    if Assigned(Temp) then
    begin
      EnterCriticalSection(FDataSection);
      FInterimBuf := Temp;
      LeaveCriticalSection(FDataSection);
      DataFlow;
      WaitForSingleObject(FIdleSemaphore, INFINITE);
    end
    else Terminate;
  end;
end;

function TBAReaderThread.ReadItem: pointer;
begin
  EnterCriticalSection(FDataSection);
  result := FInterimBuf;
  LeaveCriticalSection(FDataSection);
  if Assigned(Result) then ReleaseSemaphore(FIdleSemaphore, 1, nil);
end;

procedure TBlockToAsyncBuf.MessageHandler(var Msg: TMessage);
begin
  if (Msg.Msg = WM_BLOCK_ASYNC) then
  begin
    case TThreadNotify(Msg.LParam) of
      tnReaderDataflow: Read;
      tnWriterDataflow: Write;
    else
      Assert(false);
    end;
  end;
end;

procedure TBlockToAsyncBuf.ReaderDataFlow(Sender: TObject);
begin
  PostMessage(FHWND, WM_BLOCK_ASYNC, 0, Integer(tnReaderDataflow));
end;

procedure TBlockToAsyncBuf.WriterDataFlow(Sender: TObject);
begin
  PostMessage(FHWND, WM_BLOCK_ASYNC, 0, Integer(tnWriterDataflow));
end;

procedure TBlockToAsyncBuf.Read;
begin
  if Assigned(FOnRead) then FOnRead(Self);
end;

procedure TBlockToAsyncBuf.Write;
begin
  if Assigned(FOnWrite) then FOnWrite(Self);
end;

constructor TBlockToAsyncBuf.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FHWND := AllocateHWnd(MessageHandler);
  FBuffer := TBiDirBuf.Create;
  FBuffer.Size := InternalBufferSize;
  FReaderThread := TBAReaderThread.Create(true);
  FReaderThread.Buffer := Self.FBuffer;
  FReaderThread.OnDataFlow := ReaderDataFlow;
  FWriterThread := TBAWriterThread.Create(true);
  FWriterThread.Buffer := Self.FBuffer;
  FWriterThread.OnDataFlow := WriterDataFlow;
  FReaderThread.Resume;
  FWriterThread.Resume;
end;

procedure TBlockToAsyncBuf.ResetState;
begin
  if Assigned(FReaderThread) then FReaderThread.Terminate;
  if Assigned(FWriterThread) then FWriterThread.Terminate;
  FBuffer.ResetState;
  FReaderThread.Free;
  FWriterThread.Free;
  FReaderThread := nil;
  FWriterThread := nil;
end;

destructor TBlockToAsyncBuf.Destroy;
begin
{ A few destruction subtleties here }
  ResetState;
  FBuffer.Free;
  DeallocateHWnd(FHWND);
  inherited Destroy;
end;

function TBlockToAsyncBuf.BlockingRead: pointer;
begin
  result := FBuffer.GetItem(bsSideB);
end;

function TBlockToAsyncBuf.BlockingWrite(Item: pointer): boolean;
begin
  result := FBuffer.PutItem(bsSideB, Item);
end;

function TBlockToAsyncBuf.AsyncRead: pointer;
begin
  result := FReaderThread.ReadItem;
end;

function TBlockToAsyncBuf.AsyncWrite(Item: pointer): boolean;
begin
  result := FWriterThread.WriteItem(Item);
end;

function TBlockToAsyncBuf.GetItemsInTransit: integer;

var
  Entries: integer;

begin
  result := FReaderThread.ItemsInTransit + FWriterThread.ItemsInTransit;
  if FBuffer.GetEntriesUsed(bsSideA, Entries) then
    Inc(result, Entries);
  if FBuffer.GetEntriesUsed(bsSideB, Entries) then
    Inc(result, Entries);
end;

end.







Sample 29

unit BlockAsyncForm;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, BlockToAsyncBuf, PrimeRangeThread;

const
  MaxCount = 20;

type
  TBlockAsyncFrm = class(TForm)
    Label1: TLabel;
    StartRangeEdit: TEdit;
    Label2: TLabel;
    EndRangeEdit: TEdit;
    SubmitBtn: TButton;
    ResultsMemo: TMemo;
    procedure FormCreate(Sender: TObject);
    procedure SubmitBtnClick(Sender: TObject);
    procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
    procedure FormDestroy(Sender: TObject);
  private
{ Private declarations }
    FItemsInTransit: integer;
    FBuf: TBlockToAsyncBuf;
    FWorkerThread: TPrimeRangeThread;
    procedure BufRead(Sender: TObject);
    procedure BufWrite(Sender: TObject);
  public
{ Public declarations }
  end;

var
  BlockAsyncFrm: TBlockAsyncFrm;

implementation

{$R *.DFM}

procedure TBlockAsyncFrm.FormCreate(Sender: TObject);
begin
  FWorkerThread := TPrimeRangeThread.Create(true);
  FBuf := TBlockToAsyncBuf.Create(Self);
  with FBuf do
  begin
{ Note that these changes will take effect before
events from this component could possibly occur }
    OnRead := BufRead;
    OnWrite := BufWrite;
  end;
  SetThreadPriority(FWorkerThread.Handle, THREAD_PRIORITY_BELOW_NORMAL);
  with FWorkerThread do
  begin
    Buf := FBuf;
    Resume;
  end;
end;

procedure TBlockAsyncFrm.SubmitBtnClick(Sender: TObject);

var
  Request: PRangeRequestType;
  Temp: integer;

begin
  New(Request);
  try
    Request.Low := StrToInt(StartRangeEdit.Text);
    Request.High := StrToInt(EndRangeEdit.Text);
    if Request.Low > Request.High then
    begin
      Temp := Request.Low;
      Request.Low := Request.High;
      Request.High := Temp;
    end;
    if FBuf.AsyncWrite(Request) then
    begin
      Request := nil;
      SubmitBtn.Enabled := false;
      Inc(FItemsInTransit);
    end;
  finally
    if Assigned(Request) then Dispose(Request);
  end;
end;

procedure TBlockAsyncFrm.BufWrite(Sender: TObject);
begin
{ Buffer has indicated that there is space for us to write }
  SubmitBtn.Enabled := true;
end;

procedure TBlockAsyncFrm.BufRead(Sender: TObject);

var
  Reply: TStringList;

begin
{ We have received a notification that we may read. }
  Reply := TStringList(FBuf.AsyncRead);
  if Assigned(Reply) then
  begin
    Dec(FItemsInTransit);
    ResultsMemo.Lines.BeginUpdate;
    ResultsMemo.Lines.AddStrings(Reply);
    while ResultsMemo.Lines.Count > MaxCount do
      ResultsMemo.Lines.Delete(0);
    ResultsMemo.Lines.EndUpdate;
  end;
end;

procedure TBlockAsyncFrm.FormCloseQuery(Sender: TObject;
  var CanClose: Boolean);
begin
  CanClose := true;
  if FItemsInTransit > 0 then
    if MessageDlg('Some requests in transit, close anyway?', mtWarning,
      mbOKCancel, 0) <> mrOK then
      CanClose := false;
end;

procedure TBlockAsyncFrm.FormDestroy(Sender: TObject);
begin
  FWorkerThread.Terminate;
  FBuf.ResetState;
  FWorkerThread.WaitFor;
  FBuf.Free;
  FWorkerThread.Free;
end;

end.





Sample 30

unit PrimeRangeThread;

interface

uses
  Classes, BlockToAsyncBuf;

type
  TPrimeRangeThread = class(TThread)
  private
{ Private declarations }
    FBuf: TBlockToAsyncBuf;
  protected
    function IsPrime(TestNum: integer): boolean;
    procedure Execute; override;
  public
  published
    property Buf: TBlockToAsyncBuf read FBuf write FBuf;
  end;

  TRangeRequestType = record
    Low, High: integer;
  end;

  PRangeRequestType = ^TRangeRequestType;

{ Results returned in a string list }

implementation

uses SysUtils;

{ TPrimeRangeThread }

function TPrimeRangeThread.IsPrime(TestNum: integer): boolean;

var
  iter: integer;

begin
  result := true;
  if TestNum < 0 then
    result := false;
  if TestNum <= 2 then
    exit;
  iter := 2;
  while (iter < TestNum) and (not terminated) do {Line A}
  begin
    if (TestNum mod iter) = 0 then
    begin
      result := false;
      exit;
    end;
    Inc(iter);
  end;
end;

procedure TPrimeRangeThread.Execute;

var
  PRange: PRangeRequestType;
  TestNum: integer;
  Results: TStringList;

begin
  while not Terminated do
  begin
    PRange := PRangeRequestType(FBuf.BlockingRead);
    if Assigned(PRange) then
    begin
      Assert(PRange.Low <= PRange.High);
      Results := TStringList.Create;
      Results.Add('Primes from: ' + IntToStr(PRange.Low) +
        ' to: ' + IntToStr(PRange.High));
      for TestNum := PRange.Low to PRange.High do
      begin
        if IsPrime(TestNum) then
          Results.Add(IntToStr(TestNum) + ' is prime.');
      end;
      if not FBuf.BlockingWrite(Results) then
      begin
        Results.Free;
        Terminate;
      end;
    end
    else Terminate;
  end;
end;

end.






Sample 31


unit SimpleSync;

{ Martin Harvey 27/5/2000 }

interface

uses Windows;

type
  TSimpleSynchronizer = class(TObject)
  private
    FDataLock, FWriteLock: TRTLCriticalSection;
    FActRead, FReadRead, FActWrite, FWriteWrite: integer;
    FReaderSem, FWriterSem: THandle;
  protected
  public
    constructor Create;
    destructor Destroy; override;
    procedure StartRead;
    procedure StartWrite;
    procedure EndRead;
    procedure EndWrite;
  published
  end;

implementation

constructor TSimpleSynchronizer.Create;
begin
  inherited Create;
  InitializeCriticalSection(FDataLock);
  InitializeCriticalSection(FWriteLock);
  FReaderSem := CreateSemaphore(nil, 0, High(Integer), nil);
  FWriterSem := CreateSemaphore(nil, 0, High(Integer), nil);
{ Initial values of 0 OK for all counts }
end;

destructor TSimpleSynchronizer.Destroy;
begin
  DeleteCriticalSection(FDataLock);
  DeleteCriticalSection(FWriteLock);
  CloseHandle(FReaderSem);
  CloseHandle(FWriterSem);
  inherited Destroy;
end;

procedure TSimpleSynchronizer.StartRead;
begin
  EnterCriticalSection(FDataLock);
  Inc(FActRead);
  if FActWrite = 0 then
  begin
    Inc(FReadRead);
    ReleaseSemaphore(FReaderSem, 1, nil);
  end;
  LeaveCriticalSection(FDataLock);
  WaitForSingleObject(FReaderSem, INFINITE);
end;

procedure TSimpleSynchronizer.StartWrite;
begin
  EnterCriticalSection(FDataLock);
  Inc(FActWrite);
  if FReadRead = 0 then
  begin
    Inc(FWriteWrite);
    ReleaseSemaphore(FWriterSem, 1, nil);
  end;
  LeaveCriticalSection(FDataLock);
  WaitForSingleObject(FWriterSem, INFINITE);
  EnterCriticalSection(FWriteLock);
end;

procedure TSimpleSynchronizer.EndRead;
begin
  EnterCriticalSection(FDataLock);
  Dec(FReadRead);
  Dec(FActRead);
  if FReadRead = 0 then
  begin
    while FWriteWrite < FActWrite do
    begin
      Inc(FWriteWrite);
      ReleaseSemaphore(FWriterSem, 1, nil);
    end;
  end;
  LeaveCriticalSection(FDataLock);
end;

procedure TSimpleSynchronizer.EndWrite;
begin
  LeaveCriticalSection(FWriteLock);
  EnterCriticalSection(FDataLock);
  Dec(FWriteWrite);
  Dec(FActWrite);
  if FActWrite = 0 then
  begin
    while FReadRead < FActRead do
    begin
      Inc(FReadRead);
      ReleaseSemaphore(FReaderSem, 1, nil);
    end;
  end;
  LeaveCriticalSection(FDataLock);
end;

end.





Sample 32

unit ChecksumList;

{ Martin Harvey 29/5/2000 }

interface

uses SimpleSync, Classes, SysUtils;

type
  TChecksumList = class
  private
    FCheckList: TList;
    FSync: TSimpleSynchronizer;
  protected
{ Find function returns -1 if not found }
    function FindFileIndex(FileName: string): integer;
    function NoLockGetFileList: TStringList;
    function NoLockGetChecksum(FileName: string): integer;
  public
    constructor Create;
    destructor Destroy; override;
    procedure SetChecksum(FileName: string; Checksum: integer);
    procedure RemoveChecksum(FileName: string);
    function GetChecksum(FileName: string): integer;
    function GetFileList: TStringList;
    function GetChecksumList: TStringList;
  end;

implementation

type
  TCheckSum = record
    FileName: string;
    Checksum: integer;
  end;

  PCheckSum = ^TCheckSum;

constructor TChecksumList.Create;
begin
  inherited Create;
  FCheckList := TList.Create;
  FSync := TSimpleSynchronizer.Create;
end;

destructor TCheckSumList.Destroy;

var
  iter: integer;
  CurSum: PCheckSum;

begin
  if FCheckList.Count > 0 then
  begin
    for iter := 0 to FCheckList.Count - 1 do
    begin
      CurSum := PCheckSum(FCheckList.Items[iter]);
      if Assigned(CurSum) then Dispose(CurSum);
    end;
  end;
  FCheckList.Free;
  FSync.Free;
  inherited Destroy;
end;

function TCheckSumList.FindFileIndex(FileName: string): integer;

var
  iter: integer;
  CurSum: PCheckSum;

begin
  result := -1;
  if FCheckList.Count > 0 then
  begin
    for iter := 0 to FCheckList.Count - 1 do
    begin
      CurSum := PCheckSum(FCheckList.Items[iter]);
      Assert(Assigned(CurSum));
      if AnsiCompareText(FileName, CurSum.FileName) = 0 then
      begin
        result := iter;
        exit;
      end;
    end;
  end;
end;

procedure TCheckSumList.SetChecksum(FileName: string; Checksum: integer);

var
  CurSum: PCheckSum;
  CurIndex: integer;

begin
  FSync.StartWrite;
  CurIndex := FindFileIndex(FileName);
  if CurIndex >= 0 then
    CurSum := PCheckSum(FCheckList.Items[CurIndex])
  else
  begin
    New(CurSum);
    FCheckList.Add(CurSum);
  end;
  CurSum.FileName := FileName;
  CurSum.Checksum := Checksum;
  FSync.EndWrite;
end;

procedure TCheckSumList.RemoveChecksum(FileName: string);

var
  CurIndex: integer;

begin
  FSync.StartWrite;
  CurIndex := FindFileIndex(FileName);
  if CurIndex >= 0 then
  begin
    FCheckList.Delete(CurIndex);
    FCheckList.Pack;
  end;
  FSync.EndWrite;
end;

function TCheckSumList.NoLockGetChecksum(FileName: string): integer;

var
  CurIndex: integer;
  CurSum: PCheckSum;

begin
  result := 0;
  CurIndex := FindFileIndex(FileName);
  if CurIndex >= 0 then
  begin
    CurSum := PCheckSum(FCheckList.Items[CurIndex]);
    Assert(Assigned(CurSum));
    result := CurSum.Checksum;
  end;
end;

function TCheckSumList.GetChecksum(FileName: string): integer;
begin
  FSync.StartRead;
  result := NoLockGetChecksum(FileName);
  FSync.EndRead;
end;

function TCheckSumList.NoLockGetFileList: TStringList;

var
  iter: integer;
  CurSum: PCheckSum;

begin
  result := TStringList.Create;
  if FCheckList.Count > 0 then
  begin
    for iter := 0 to FCheckList.Count - 1 do
    begin
      CurSum := PCheckSum(FCheckList.Items[iter]);
      Assert(Assigned(CurSum));
      result.Add(CurSum.FileName);
    end;
  end;
  result.Sort;
end;

function TCheckSumList.GetFileList: TStringList;
begin
  FSync.StartRead;
  result := NoLockGetFileList;
  FSync.EndRead;
end;

function TCheckSumList.GetChecksumList: TStringList;

var
  iter: integer;

begin
  FSync.StartRead;
  result := NoLockGetFileList;
  if result.Count > 0 then
  begin
    for iter := 0 to result.Count - 1 do
    begin
      result.strings[iter] := result.strings[iter]
        + ' ' + IntToStr(NoLockGetChecksum(result.strings[iter]));
    end;
  end;
  FSync.EndRead;
end;

end.





Sample 33


unit CheckThread;

{ Martin Harvey 30/5/2000 }

interface

uses
  Classes, Windows, ChecksumList, SysUtils;

type

  TState = (sGetCurrentCRCs,
    sBuildFileList,
    sRemoveCRCs,
    sCheckFile,
    sDone);

  TStateReturn = (rvOK, rvFail1, rvFail2);

  TActionFunc = function: TStateReturn of object;

  TStateActions = array[TState] of TActionFunc;

  TNextStates = array[TState, TStateReturn] of TState;

  TCheckThread = class(TThread)
  private
    FStartDir: string;
    FCurrentState: TState;
    FActionFuncs: TStateActions;
    FNextStates: TNextStates;
    FInternalFileList: TStringList;
    FExternalFileList: TStringList;
    FExternalCRCList: TStringList;
    FCheckList: TChecksumList;
    FFileToProcess: integer;
  protected
    procedure InitActionFuncs;
    procedure InitNextStates;
    function GetCurrentCRCs: TStateReturn;
    function BuildFileList: TStateReturn;
    function RemoveCRCs: TStateReturn;
    function CheckFile: TStateReturn;
    procedure Execute; override;
  public
    constructor Create(CreateSuspended: boolean);
    destructor Destroy; override;
    property StartDir: string read FStartDir write FStartDir;
    property CheckList: TChecksumList read FCheckList write FCheckList;
  end;

implementation

{ TCheckThread }

{(*} {Prettyprinter auto-formatting off}

const
BaseStateTransitions:TNextStates = (
{rvOK} {rvFail1} {rvFail2}
{sGetCurrentCRCs } ( sBuildFileList, sDone, sDone ),
{sBuildFileList } ( sRemoveCRCs, sDone, sDone ),
{sRemoveCRCs } ( sCheckFile, sDone, sDone ),
{sCheckFile } ( sCheckFile, sGetCurrentCRCs, sDone ),
{sDone } ( sDone, sDone, sDone ));

{*)}{Prettyprinter auto-formatting on}

procedure TCheckThread.InitActionFuncs;
begin
  FActionFuncs[sGetCurrentCRCs] := GetCurrentCRCs;
  FActionFuncs[sBuildFileList] := BuildFileList;
  FActionFuncs[sRemoveCRCs] := RemoveCRCs;
  FActionFuncs[sCheckFile] := CheckFile;
end;

procedure TCheckThread.InitNextStates;
begin
  FNextStates := BaseStateTransitions;
end;

function TCheckThread.GetCurrentCRCs: TStateReturn;
begin
  FExternalFileList.Free;
  FExternalFileList := nil;
  FExternalCRCList.Free;
  FExternalCRCList := nil;

  FExternalFileList := FCheckList.GetFileList;
  FExternalCRCList := FCheckList.GetChecksumList;
  result := rvOK;
end;

function TCheckThread.BuildFileList: TStateReturn;

var
  FindRet: integer;
  SearchRec: TSearchRec;

begin
  FInternalFileList.Clear;
  FindRet := FindFirst(StartDir + '*.*', faAnyFile and not faDirectory, SearchRec);
  if FindRet <> 0 then
    result := rvFail1
  else
  begin
    while FindRet = 0 do
    begin
{ Found a file.}
      FInternalFileList.Add(SearchRec.Name);
      FindRet := FindNext(SearchRec);
    end;
    result := rvOK;
  end;
  FindClose(SearchRec);
  FFileToProcess := 0;
end;

function TCheckThread.RemoveCRCs: TStateReturn;

var
  iter: integer;
  dummy: integer;

begin
  FInternalFileList.Sort;
  FExternalFileList.Sort;
  if FExternalFileList.Count > 0 then
  begin
    for iter := 0 to FExternalFileList.Count - 1 do
    begin
      if not FInternalFileList.Find(FExternalFileList[iter], dummy) then
        FCheckList.RemoveChecksum(FExternalFileList[iter]);
    end;
  end;
  result := rvOK;

end;

function TCheckThread.CheckFile: TStateReturn;

var
  FileData: TFileStream;
  MemImage: TMemoryStream;
  Data: byte;
  Sum: integer;
  iter: integer;

begin
  if FFileToProcess >= FInternalFileList.Count then
  begin
    result := rvFail1;
    exit;
  end;
  Sum := 0;
  FileData := nil;
  MemImage := nil;
  try
    FileData := TFileStream.Create(StartDir + FInternalFileList[FFileToProcess],
      fmOpenRead or fmShareDenyWrite);
    FileData.Seek(0, soFromBeginning);
    MemImage := TMemoryStream.Create;
    MemImage.CopyFrom(FileData, FileData.Size);
    MemImage.Seek(0, soFromBeginning);
    for iter := 1 to FileData.Size do
    begin
      MemImage.ReadBuffer(Data, sizeof(Data));
      Inc(Sum, Data);
    end;
    FileData.Free;
    MemImage.Free;
    if (FCheckList.GetChecksum(FInternalFileList[FFileToProcess]) <> Sum) then
      FCheckList.SetChecksum(FInternalFileList[FFileTOProcess], Sum);
  except
    on EStreamError do
    begin
      FileData.Free;
      MemImage.Free;
    end;
  end;
  Inc(FFileToProcess);
  result := rvOK;
end;

procedure TCheckThread.Execute;
begin
  SetThreadPriority(Handle, THREAD_PRIORITY_IDLE);
  while not (Terminated or (FCurrentState = sDone)) do
    FCurrentState := FNextStates[FCurrentState, FActionFuncs[FCurrentState]];
end;

constructor TCheckThread.Create(CreateSuspended: boolean);
begin
  inherited Create(CreateSuspended);
  InitActionFuncs;
  InitNextStates;
  FInternalFileList := TStringList.Create;
end;

destructor TCheckThread.Destroy;
begin
  FInternalFileList.Free;
  FExternalFileList.Free;
  FExternalCRCList.Free;
  inherited Destroy;
end;

end.





Sample 34

unit SyncForm;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  ExtCtrls, StdCtrls, ChecksumList, CheckThread;

type
  TForm1 = class(TForm)
    FileMemo: TMemo;
    Timer1: TTimer;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure Timer1Timer(Sender: TObject);
  private
{ Private declarations }
    FChecksumList: TChecksumList;
    FCheckThread: TCheckThread;
  public
{ Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);
begin
  FChecksumList := TChecksumList.Create;
  FCheckThread := TCheckThread.Create(true);
  with FCheckThread do
  begin
    StartDir := 'D:\Netscape Profiles\Martin\News\host-newsgroups.borland.com\';
    CheckList := FChecksumList;
    Resume;
  end;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  with FCheckThread do
  begin
    Terminate;
    WaitFor;
    Free;
  end;
  FChecksumList.Free;
end;

procedure TForm1.Timer1Timer(Sender: TObject);

var
  TempList: TStringList;

begin
  TempList := FChecksumList.GetChecksumList;
  with FileMemo do
  begin
    with Lines do
    begin
      BeginUpdate;
      Assign(TempList);
      EndUpdate;
    end;
    selstart := gettextlen;
    perform(em_scrollcaret, 0, 0);
  end;
  TempList.Free;
end;

end.





Sample 35

unit SimulatedEvent;

{ Martin Harvey 4/6/2000 }

interface

uses Windows;

type
  TSimulatedEvent = class
  private
    FBlockCount: integer;
    FSignalled: boolean;
    FDataSection: TRTLCriticalSection;
    FBlockSem: THandle;
  protected
  public
    constructor Create(CreateSignalled: boolean);
    destructor Destroy; override;
    procedure SetEvent;
    procedure ResetEvent;
    procedure PulseEvent;
    procedure WaitFor;
  published
  end;

implementation

constructor TSimulatedEvent.Create(CreateSignalled: boolean);
begin
  inherited Create;
  FSignalled := CreateSignalled;
  InitializeCriticalSection(FDataSection);
  FBlockSem := CreateSemaphore(nil, 0, High(Integer), nil);
end;

destructor TSimulatedEvent.Destroy;
begin
  DeleteCriticalSection(FDataSection);
  CloseHandle(FBlockSem);
  inherited Destroy;
end;

procedure TSimulatedEvent.SetEvent;
begin
  EnterCriticalSection(FDataSection);
  FSignalled := true;
  while FBlockCount > 0 do
  begin
    ReleaseSemaphore(FBlockSem, 1, nil);
    Dec(FBlockCount);
  end;
  LeaveCriticalSection(FDataSection);
end;

procedure TSimulatedEvent.ResetEvent;
begin
  EnterCriticalSection(FDataSection);
  FSignalled := false;
  LeaveCriticalSection(FDataSection);
end;

procedure TSimulatedEvent.PulseEvent;
begin
  EnterCriticalSection(FDataSection);
  while FBlockCount > 0 do
  begin
    ReleaseSemaphore(FBlockSem, 1, nil);
    Dec(FBlockCount);
  end;
  LeaveCriticalSection(FDataSection);
end;

procedure TSimulatedEvent.WaitFor;
begin
  EnterCriticalSection(FDataSection);
  if FSignalled then
  begin
    Dec(FBlockCOunt);
    ReleaseSemaphore(FBlockSem, 1, nil);
  end;
  Inc(FBlockCount);
  LeaveCriticalSection(FDataSection);
  WaitForSingleObject(FBlockSem, INFINITE);
end;

end.






Sample 36






unit EventSync;

{ Martin Harvey 5/6/2000 }

interface

uses Windows;

type
  TEventSynchronizer = class(TObject)
  private
    FDataLock, FWriteLock: TRTLCriticalSection;
    FReaders, FWriters: integer;
    FNoReaders, FNoWriters: THandle;
  protected
  public
    constructor Create;
    destructor Destroy; override;
    procedure StartRead;
    procedure StartWrite;
    procedure EndRead;
    procedure EndWrite;
  published
  end;

implementation

constructor TEventSynchronizer.Create;
begin
  inherited Create;
  InitializeCriticalSection(FDataLock);
  InitializeCriticalSection(FWriteLock);
  FNoReaders := CreateEvent(nil, true, true, nil);
  FNoWriters := CreateEvent(nil, true, true, nil);
end;

destructor TEventSynchronizer.Destroy;
begin
  DeleteCriticalSection(FDataLock);
  DeleteCriticalSection(FWriteLock);
  CloseHandle(FNoReaders);
  CloseHandle(FNoWriters);
  inherited Destroy;
end;

procedure TEventSynchronizer.StartRead;

var
  Block: boolean;

begin
  EnterCriticalSection(FDatalock);
  if FReaders = 0 then
    ResetEvent(FNoReaders);
  Inc(FReaders);
  Block := FWriters > 0;
  LeaveCriticalSection(FDataLock);
  if Block then
    WaitForSingleObject(FNoWriters, INFINITE);
end;

procedure TEventSynchronizer.StartWrite;

var
  Block: boolean;

begin
  EnterCriticalSection(FDataLock);
  if FWriters = 0 then
    ResetEvent(FNoWriters);
  Inc(FWriters);
  Block := FReaders > 0;
  LeaveCriticalSection(FDataLock);
  if Block then
    WaitForSingleObject(FNoReaders, INFINITE);
  EnterCriticalSection(FWriteLock);
end;

procedure TEventSynchronizer.EndRead;
begin
  EnterCriticalSection(FDataLock);
  Dec(FReaders);
  if FReaders = 0 then
    SetEvent(FNoReaders);
  LeaveCriticalSection(FDataLock);
end;

procedure TEventSynchronizer.EndWrite;
begin
  LeaveCriticalSection(FWriteLock);
  EnterCriticalSection(FDataLock);
  Dec(FWriters);
  if FWriters = 0 then
    SetEvent(FNoWriters);
  LeaveCriticalSection(FDataLock);
end;

end.







Sample 37

var
  Lock: integer;

{Lock Initialization}
  Lock := -1;

{Entering the spin lock}
  while InterlockedIncrement(Lock) > 0 do
  begin
    Dec(Lock);
    Sleep(0);
  end;

{Leaving the spin lock}
  Dec(Lock);





Sample 38

procedure DoSomethingCritical(var Lock: integer);

var
  Temp: integer;

begin
{ Initialize lock }
  Lock := -1;
{ Enter Lock }
  repeat
    Inc(Lock);
    Temp := Lock;
    if Temp > 0 then
      Dec(Lock);
  until not (Temp > 0);
{ Perform operations }
{ Leave Lock }
  Dec(Lock);
end;

procedure AsmDoSomethingCritical(var Lock: integer);
asm
{ Initialize lock }
lock mov dword ptr[eax],$FFFFFFFF
{ Enter Lock }
@spin:
lock inc dword ptr[eax]
mov edx,[eax]
test edx,edx
jng @skipdec
lock dec dword ptr[eax]
@skipdec:
test edx,edx
jg @spin
{ Perform operations }
{ Leave Lock }
lock dec dword ptr[eax]
end;





Sample 39

type
  TEventCount = class
  private
  protected
  public
    constructor Create;
    destructor Destroy; override;
    function Advance: integer;
    function Read: integer;
    procedure Await(WaitCount: integer);
  published
  end;

  TSequencer = class
  private
  protected
  public
    constructor Create;
    destructor Destroy; override;
    function Ticket: integer;
  published
  end;





Sample 40

{ Enforcing a mutual exclusion }

var
  MyTurn: integer;
  EC: TEventCount;
  S: TSequencer; { assume already created appropriately }

begin
  MyTurn := S.Ticket;
  EC.Await(MyTurn);
{ Critical operations }
  EC.Advance;
end;






Sample 41

{ Single producer consumer bounded buffer }
{ buffer has N slots }

var
  InE, OutE: TEventCount; { Set up and initially 0 }

{ producer }

var
  I: integer;

begin
  while not terminated do
  begin
    OutE.Await(I - N);
{ insert item at I mod N }
    InE.Advance;
    Inc(I);
  end;
end;

{ consumer }

var
  I: integer;

begin
  while not terminated do
  begin
    InE.Await(I);
{ remove item at i mod N }
    OutE.Advance;
  end;
end;







Sample 42







{ Bounded buffer with multiple producers and consumers }

var
  InE, OutE: TEventCount; { Set up and initially 0 }
  PrTk, CnTk: TSequencer; { Set up and initially 0 }

{ producer }

var
  MyTurn: integer;

begin
  while not terminated do
  begin
    MyTurn := PrTk.Ticket;
    InE.Await(MyTurn);
    OutE.Await(MyTurn - N + 1);
{ insert item at myturn mod N }
    InE.Advance;
  end;
end;

{ consumer }

var
  MyTurn: integer;

begin
  while not terminated do
  begin
    MyTurn := CnTk.Ticket;
    OutE.Await(MyTurn);
    InE.Await(MyTurn + 1);
{ remove item at MyTurn mod N }
    OutE.Advance;
  end;
end;