{
    Реазилация быстрого двухстороннего стекового аллокатора.

    Использует переданную область память (пользовательскую или выделенную
    в куче). Можно выделять с обеих концов.
    
    При нехватке памяти можно добавить ещё памяти при помощи
      AddClientMemory
    или
      AddHeapMemory
    (отсюда и название).
}
{$MODE FPC}
{$MODESWITCH OUT}
{$MODESWITCH RESULT}
unit dchainedallocator;

interface

type
PChainedAllocator = ^TChainedAllocator;
TChainedAllocator = object
private type
  PNode = ^TNode;
  TNode = record
    Start: Pointer;
    Size: SizeUInt;
    Previous: PNode;
    MemoryType: Cardinal; // see MEMORY_TYPE_* consts in implementation
  end;
private
  FLeft: PByte;
  FRight: PByte;
  FNode: TNode;
public
  procedure Init;
  procedure Init(Start: Pointer; Size: SizeUInt);
  procedure Init(const Buf: array of Byte); inline;
  procedure Done; inline;
  procedure AddClientMemory(Start: Pointer; Size: SizeUInt);
  procedure AddHeapMemory(Start: Pointer; Size: SizeUInt);
  function TryAllocLeft(Size: SizeUInt): Pointer;
  function TryAllocRight(Size: SizeUInt): Pointer;
  function TryAllocLeft(Size: SizeUInt; out P: Pointer): Boolean;
  function TryAllocRight(Size: SizeUInt; out P: Pointer): Boolean;
  procedure DeallocLeft(Size: SizeUInt);
  procedure DeallocRight(Size: SizeUInt);
  procedure DeallocAllLeft;
  procedure DeallocAllRight;
  property Left: PByte read FLeft;
  property Right: PByte read FRight;
end;

implementation

const
  MEMORY_TYPE_CLIENT = 1;
  MEMORY_TYPE_HEAP   = 2;

procedure FreeNodes(Node: TChainedAllocator.PNode);
var
  Start: Pointer;
  NodeData: TChainedAllocator.TNode;
begin
  if Node <> nil then begin
    NodeData := Node^;
    while Node <> nil do begin
      if NodeData.MemoryType = MEMORY_TYPE_HEAP then begin
        Start := NodeData.Start;
        Node := NodeData.Previous;
        if Node <> nil then
          NodeData := Node^;
        FreeMem(Start);
      end else begin
        Node := NodeData.Previous;
        if Node <> nil then
          NodeData := Node^;
      end;
    end;
  end;
end;

procedure TChainedAllocator.Init;
begin
  FLeft := nil;
  FRight := nil;
  FNode.Start := nil;
  FNode.Size := 0;
  FNode.Previous := nil;
  FNode.MemoryType := MEMORY_TYPE_CLIENT;
end;

procedure TChainedAllocator.Init(Start: Pointer; Size: SizeUInt);
begin
  FLeft := Start;
  FRight := FLeft + Size;
  FNode.Start := Start;
  FNode.Size := Size;
  FNode.Previous := nil;
  FNode.MemoryType := MEMORY_TYPE_CLIENT;
end;

procedure TChainedAllocator.Init(const Buf: array of Byte);
begin
  Init(@Buf[0], Length(Buf));
end;

procedure TChainedAllocator.Done;
begin
  FreeNodes(@FNode);
end;

procedure TChainedAllocator.AddClientMemory(Start: Pointer; Size: SizeUInt);
var
  PreviousNode: PNode;
begin
  if Size <= SizeOf(TNode) then
    Exit;
  if FNode.Start <> nil then begin
    PreviousNode := PNode(PByte(Start) + Size - SizeOf(TNode));
    PreviousNode^ := FNode;
    FNode.Previous := PreviousNode;
    FRight := PByte(PreviousNode);
  end else begin
    FNode.Previous := nil;
    FRight := PByte(Start) + Size;
  end;
  FNode.Start := Start;
  FNode.Size := Size;
  FNode.MemoryType := MEMORY_TYPE_CLIENT;
  FLeft := FNode.Start;
end;

procedure TChainedAllocator.AddHeapMemory(Start: Pointer; Size: SizeUInt);
var
  PreviousNode: PNode;
begin
  if Size <= SizeOf(TNode) then begin
    FreeMem(Start); // :)
    Exit;
  end;
  PreviousNode := PNode(PByte(Start) + Size - SizeOf(TNode));
  PreviousNode^ := FNode;
  FNode.Start := Start;
  FNode.Size := Size;
  FNode.Previous := PreviousNode;
  FNode.MemoryType := MEMORY_TYPE_HEAP;
  FLeft := FNode.Start;
  FRight := PByte(PreviousNode);
end;

function TChainedAllocator.TryAllocLeft(Size: SizeUInt): Pointer;
begin
  Result := FLeft;
  Inc(FLeft, Size);
  if FLeft > FRight then begin
    Dec(FLeft, Size);
    Result := nil;
  end;
end;

function TChainedAllocator.TryAllocRight(Size: SizeUInt): Pointer;
begin
  Dec(FRight, Size);
  if FLeft > FRight then begin
    Inc(FRight, Size);
    Result := nil;
  end else begin
    Result := FRight;
  end;
end;

function TChainedAllocator.TryAllocLeft(Size: SizeUInt; out P: Pointer): Boolean;
begin
  P := TryAllocLeft(Size);
  Result := P <> nil;
end;

function TChainedAllocator.TryAllocRight(Size: SizeUInt; out P: Pointer): Boolean;
begin
  P := TryAllocRight(Size);
  Result := P <> nil;
end;

procedure TChainedAllocator.DeallocLeft(Size: SizeUInt);
begin
  Dec(FLeft, Size);
  if FLeft < PByte(FNode.Start) then
    FLeft := FNode.Start;
end;

procedure TChainedAllocator.DeallocRight(Size: SizeUInt);
begin
  Inc(FRight, Size);
  if FRight > PByte(FNode.Start) + FNode.Size then
    FRight := PByte(FNode.Start) + FNode.Size;
end;

procedure TChainedAllocator.DeallocAllLeft;
begin
  FLeft := FNode.Start;
end;

procedure TChainedAllocator.DeallocAllRight;
begin
  FRight := PByte(FNode.Start) + FNode.Size;
end;

end.
