freepascal.ru

Код: Выделить всё

iteration: 
  signal := false;
  repeat until signal;
  do_work;
goto iteration;

Код: Выделить всё

{$mode objfpc}
uses
  SysUtils, Classes;

type
  Queue = class
    constructor Create(producers: cardinal);
    destructor Destroy; override;
    procedure Put(const item: string);
    function Get(out item: string): boolean; // ждёт; либо возвращает false, если очередь пуста и не осталось производителей
    procedure KillProducer;

  private type
    PItem = ^ItemRec;
    ItemRec = record
      next: PItem;
      data: string;
    end;

  var
    mutex: TRTLCriticalSection;
    nonemptyOrFinished: PRTLEvent;
    first, last: PItem;
    activeProducers: cardinal;
    procedure Lock;
    procedure Unlock;
    procedure Clear;
  end;

  constructor Queue.Create(producers: cardinal);
  begin
    inherited Create;
    InitCriticalSection(mutex);
    nonemptyOrFinished := RTLEventCreate;
    first := nil; last := nil;
    activeProducers := producers;
  end;

  destructor Queue.Destroy;
  begin
    Clear;
    RTLEventDestroy(nonemptyOrFinished);
    DoneCriticalSection(mutex);
    inherited Destroy;
  end;

  procedure Queue.Put(const item: string);
  var
    it: PItem;
  begin
    new(it);
    it^.next := nil;
    it^.data := item;

    Lock;
    if Assigned(last) then
    begin
      last^.next := it;
      last := it;
    end else
    begin
      first := it;
      last := it;
      RTLEventSetEvent(nonemptyOrFinished); // очередь стала непустой, ждущие могут этим заинтересоваться
    end;
    Unlock;
  end;

  function Queue.Get(out item: string): boolean;
  label again;
  var
    finished: boolean;
    it: PItem;
  begin
    again: Lock;
    it := first;
    if not Assigned(it) then
    begin
      finished := activeProducers = 0;
      Unlock;
      if finished then exit(false);

      // ждём, пока в очереди не появятся элементы, или не убьются все производители
      RTLEventWaitFor(nonemptyOrFinished);

      // Внимание. Обычно у событий настраивается режим auto-reset или manual reset.
      // Для RTLEvent это не так, они всегда auto-reset, т. е. пропускают ровно один ожидающий поток и автоматически сбрасываются.
      // Если нужно поведение как у manual reset, придётся выставить назад вручную (перепроверив условие).
      // Если заменить RTLEvent на тот же TEvent с ManualReset, три строчки ниже можно убрать.
      Lock;
      if Assigned(first) or (activeProducers = 0) then RTLEventSetEvent(nonemptyOrFinished);
      Unlock;

      // <- т. к. код не под критической секцией (ждать, не выходя из критической секции - плохая идея), сюда мог вклиниться
      //    другой потребитель, так что нужно перепроверить
      goto again;
    end;

    item := it^.data;
    first := it^.next;
    if not Assigned(first) then
    begin
      last := nil;
      if activeProducers > 0 then
        // очередь пуста, но ещё могут прийти новые элементы, так что ждущие пусть ждут
        RTLEventResetEvent(nonemptyOrFinished);
    end;
    Unlock;
    dispose(it);
    result := true;
  end;

  procedure Queue.KillProducer;
  begin
    Lock;
    dec(activeProducers);
    if activeProducers = 0 then RTLEventSetEvent(nonemptyOrFinished); // все производители умерли, новых элементов не будет, ждущие могут заинтересоваться
    Unlock;
  end;

  procedure Queue.Lock;
  begin
    EnterCriticalSection(mutex);
  end;

  procedure Queue.Unlock;
  begin
    LeaveCriticalSection(mutex);
  end;

  procedure Queue.Clear;
  var
    cur, t: PItem;
  begin
    Lock;
    cur := first;
    while Assigned(cur) do
    begin
      t := cur;
      cur := cur^.next;
      dispose(t);
    end;
    first := nil; last := nil;
    Unlock;
  end;

type
  ProducerConsumerThread = class(TThread)
    constructor Create(newQ: Queue; newId: cardinal);
  protected
    q: Queue;
    id: cardinal;
  end;

  ProducerThread = class(ProducerConsumerThread)
  protected
    procedure Execute; override;
  end;

  ConsumerThread = class(ProducerConsumerThread)
  protected
    procedure Execute; override;
  end;

  constructor ProducerConsumerThread.Create(newQ: Queue; newId: cardinal);
  begin
    q := newQ;
    id := newId;
    inherited Create(false); // CreateSuspended
  end;

  procedure ProducerThread.Execute;
  const
    Items: array[0 .. 2] of string = ('Item1', 'Item2', 'Item3');
  var
    i: integer;
    item: string;
  begin
    writeln(Format('Producer%d started', [id]));
    for i := 0 to High(Items) do
    begin
      Sleep(200);
      item := Format('P%d-%s', [id, Items[i]]);
      writeln(Format('Producer%d created %s', [id, item]));
      q.Put(item);
    end;
    q.KillProducer;
    writeln(Format('Producer%d finished', [id]));
  end;

  procedure ConsumerThread.Execute;
  var
    item: string;
  begin
    writeln(Format('Consumer%d started', [id]));
    while q.Get(item) do
    begin
      Sleep(300);
      writeln(Format('Consumer%d got %s', [id, item]));
    end;
    writeln(Format('Consumer%d finished', [id]));
  end;

var
  q: Queue;
  producers: array[0 .. 1] of TThread;
  consumers: array[0 .. 2] of TThread;
  i: integer;

begin
  q := Queue.Create(length(producers));

  for i := 0 to High(producers) do producers[i] := ProducerThread.Create(q, 1 + i);
  for i := 0 to High(consumers) do consumers[i] := ConsumerThread.Create(q, 1 + i);

  for i := 0 to High(producers) do producers[i].WaitFor;
  for i := 0 to High(consumers) do consumers[i].WaitFor;

  for i := 0 to High(producers) do producers[i].Free;
  for i := 0 to High(consumers) do consumers[i].Free;

  q.Free;
end.

Код: Выделить всё

program project1;

{$mode delphi}{$H+}

uses
  {$IFDEF UNIX}cthreads,{$endif} Classes, SysUtils;

type

  { TCountThread }

  TCountThread = class(TThread)
  protected
    procedure Execute; override;
  public
    ev : PRTLEvent;
    num: integer;
    constructor Create;
    destructor Destroy; override;
  end;

{ TCountThread }

procedure TCountThread.Execute;
var
  i : integer;
begin
  while not Terminated do begin
    RTLeventWaitFor(ev);
    if not Terminated then begin
      for i:=0 to 10 do begin
        write(num,'...');
        sleep(200);
        if Terminated then Break;
      end;
      writeln;
      RTLeventResetEvent(ev);
    end;
  end;
end;

constructor TCountThread.Create;
begin
  inherited Create(false);
  ev:=RTLEventCreate;
end;

destructor TCountThread.Destroy;
begin
  RTLeventdestroy(ev);
  inherited Destroy;
end;

var
  thr : TCountThread;
  s   : string;
  err : integer;
  k   : integer;
begin
  writeln('starting');
  thr := TCountThread.Create;
  repeat
    readln(s);
    Val(s, k, err);
    if err=0 then begin
      thr.num:=k;
      RTLeventSetEvent(thr.ev);
    end;
  until err <> 0;
  writeln('stopping');

  thr.Terminate;
  RTLeventSetEvent(thr.ev);
  thr.WaitFor;
  thr.Free;
end.

Код: Выделить всё

RTLeventSetEvent(self.ev);