* Initial version

fcl/inc/cachecls.pp

@@ -0,0 +1,334 @@
+{
+    $Id$
+
+    Generic cache class for FCL
+    Copyright (C) 2000 by Sebastian Guenther ([email protected])
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+}
+
+
+unit CacheCls;
+
+interface
+
+uses SysUtils;
+
+resourcestring
+  SInvalidIndex = 'Invalid index %i';
+
+type
+
+{ TCache }
+
+  TCache = class;
+
+  ECacheError = class(Exception);
+
+  { All slots are contained both in an array and in a double-linked list.
+    * The array, which doesn't need any additional memory, can be used for fast
+      sequential access; its indices can be exported to the user of the cache.
+    * The linked list is used for on-the-fly reordering of the elements, so
+      that the elements are MRU-sorted: The most recently used element is the
+      head, the last recently used element is the tail of the list. We need a
+      double-linked list: When the MRU value of an element changes, we will
+      have to walk the list reversed, but when we are searching for an entry,
+      we will search starting from the head. }
+
+  PCacheSlot = ^TCacheSlot;
+  TCacheSlot = record
+    Prev, Next: PCacheSlot;	// -> double-linked list
+    Data: Pointer;		// The custom data associated with this element
+    Index: Integer;		// The array index of this slot
+  end;
+
+  PCacheSlotArray = ^TCacheSlotArray;
+  TCacheSlotArray = array[0..MaxInt div SizeOf(TCacheSlot) - 1] of TCacheSlot;
+
+  TOnIsDataEqual = function(ACache: TCache;
+    AData1, AData2: Pointer): Boolean of object;
+  TOnFreeSlot = procedure(ACache: TCache; SlotIndex: Integer) of object;
+
+
+  { TCache implements a generic cache class.
+    If you use the "Add" method and not only "AddNew", you will have to set
+    the "OnIsDataEqual" property to your own compare function! }
+
+  TCache = class
+  private
+    FOnIsDataEqual: TOnIsDataEqual;
+    FOnFreeSlot: TOnFreeSlot;
+    function GetData(SlotIndex: Integer): Pointer;
+    function GetSlot(SlotIndex: Integer): PCacheSlot;
+    procedure SetData(SlotIndex: Integer; AData: Pointer);
+    procedure SetMRUSlot(ASlot: PCacheSlot);
+    procedure SetSlotCount(ACount: Integer);
+  protected
+    FSlotCount: Integer;	// Number of cache elements
+    FSlots: PCacheSlotArray;
+    FMRUSlot,			// First slot in MRU-sorted list
+      FLRUSlot: PCacheSlot;	// Last slot in MRU-sorted list
+  public
+    constructor Create(ASlotCount: Integer);
+    destructor Destroy; override;
+
+    function Add(AData: Pointer): Integer;		// Checks for duplicates
+    function AddNew(AData: Pointer): Integer;		// No duplicate checks
+    function FindSlot(AData: Pointer): PCacheSlot;	// nil => not found
+    function IndexOf(AData: Pointer): Integer;		// -1 => not found
+    procedure Remove(AData: Pointer);
+
+    // Accesses to the "Data" array will be reflected by the MRU list!
+    property Data[SlotIndex: Integer]: Pointer read GetData write SetData;
+    property MRUSlot: PCacheSlot read FMRUSlot write SetMRUSlot;
+    property LRUSlot: PCacheSlot read FLRUSlot;
+    property SlotCount: Integer read FSlotCount write SetSlotCount;
+    property Slots[SlotIndex: Integer]: PCacheSlot read GetSlot;
+
+    property OnIsDataEqual: TOnIsDataEqual
+      read FOnIsDataEqual write FOnIsDataEqual;
+    { OnFreeSlot is called when a slot is being released. This can only happen
+      during Add or AddNew, when there is no more free slot available. }
+    property OnFreeSlot: TOnFreeSlot read FOnFreeSlot write FOnFreeSlot;
+  end;
+
+
+implementation
+
+
+{ TCache }
+
+function TCache.GetData(SlotIndex: Integer): Pointer;
+begin
+  if (SlotIndex < 0) or (SlotIndex >= SlotCount) then
+    raise ECacheError.CreateFmt(SInvalidIndex, [SlotIndex]);
+  MRUSlot := @FSlots^[SlotIndex];
+  Result := MRUSlot^.Data;
+end;
+
+function TCache.GetSlot(SlotIndex: Integer): PCacheSlot;
+begin
+  if (SlotIndex < 0) or (SlotIndex >= SlotCount) then
+    raise ECacheError.CreateFmt(SInvalidIndex, [SlotIndex]);
+  Result := @FSlots^[SlotIndex];
+end;
+
+procedure TCache.SetData(SlotIndex: Integer; AData: Pointer);
+begin
+  if (SlotIndex < 0) or (SlotIndex >= FSlotCount) then
+    raise ECacheError.CreateFmt(SInvalidIndex, [SlotIndex]);
+  MRUSlot := @FSlots^[SlotIndex];
+  MRUSlot^.Data := AData;
+end;
+
+procedure TCache.SetMRUSlot(ASlot: PCacheSlot);
+begin
+  if ASlot <> FMRUSlot then
+  begin
+    // Unchain ASlot
+    if Assigned(ASlot^.Prev) then
+      ASlot^.Prev^.Next := ASlot^.Next;
+    if Assigned(ASlot^.Next) then
+      ASlot^.Next^.Prev := ASlot^.Prev;
+
+    if ASlot = FLRUSlot then
+      FLRUSlot := ASlot^.Prev;
+
+    // Make ASlot the head of the double-linked list
+    ASlot^.Prev := nil;
+    ASlot^.Next := FMRUSlot;
+    FMRUSlot^.Prev := ASlot;
+    FMRUSlot := ASlot;
+    if not Assigned(FMRUSlot^.Next) then
+      FLRUSlot := FMRUSlot;
+  end;
+end;
+
+procedure TCache.SetSlotCount(ACount: Integer);
+var
+  Slot: PCacheSlot;
+  i: Integer;
+begin
+  if ACount <> SlotCount then
+  begin
+    if ACount < SlotCount then
+    begin
+      // Remove slots
+
+      if Assigned(OnFreeSlot) then
+        for i := ACount to SlotCount - 1 do
+	  OnFreeSlot(Self, i);
+
+      while (MRUSlot^.Index >= ACount) and Assigned(MRUSlot^.Next) do
+        FMRUSlot := MRUSlot^.Next;
+      MRUSlot^.Prev := nil;
+
+      while (LRUSlot^.Index >= ACount) and Assigned(LRUSlot^.Prev) do
+        FLRUSlot := LRUSlot^.Prev;
+      LRUSlot^.Next := nil;
+
+      Slot := MRUSlot^.Next;
+      while Assigned(Slot) do
+      begin
+        if Slot^.Index >= ACount then
+	begin
+	  Slot^.Prev^.Next := Slot^.Next;
+	  if Assigned(Slot^.Next) then
+	    Slot^.Next^.Prev := Slot^.Prev;
+	end;
+        Slot := Slot^.Next;
+      end;
+
+      ReallocMem(FSlots, ACount * SizeOf(TCacheSlot));
+    end else
+    begin
+      // Add new slots
+      ReallocMem(FSlots, ACount * SizeOf(TCacheSlot));
+      for i := SlotCount to ACount - 1 do
+        with FSlots^[i] do
+        begin
+	  Prev := @FSlots^[i + 1];
+	  Next := @FSlots^[i - 1];
+	  Data := nil;
+	  Index := i;
+        end;
+      LRUSlot^.Next := @FSlots^[ACount - 1];
+      FSlots^[ACount - 1].Prev := LRUSlot;
+      FLRUSlot := @FSlots^[SlotCount];
+      FLRUSlot^.Next := nil;
+    end;
+    FSlotCount := ACount;
+  end;
+end;
+
+constructor TCache.Create(ASlotCount: Integer);
+var
+  i: Integer;
+begin
+  inherited Create;
+  FSlotCount := ASlotCount;
+
+  if FSlotCount = 0 then
+    exit;
+
+  { Allocate the slots and initialize the double-linked list.
+    Note: The list is set up so that the last recently used
+    slot is the first slot! }
+
+  GetMem(FSlots, FSlotCount * SizeOf(TCacheSlot));
+
+  FMRUSlot := @FSlots^[FSlotCount - 1];
+  FLRUSlot := @FSlots^[0];
+
+  with FSlots^[0] do
+  begin
+    if FSlotCount > 1 then
+      Prev := @FSlots^[1]
+    else
+      Prev := nil;
+    Next := nil;
+    Data := nil;
+    Index := 0;
+  end;
+
+  for i := 1 to FSlotCount - 2 do
+    with FSlots^[i] do
+    begin
+      Next := @FSlots^[i - 1];
+      Prev := @FSlots^[i + 1];
+      Data := nil;
+      Index := i;
+    end;
+
+  with FSlots^[FSlotCount - 1] do
+  begin
+    Prev := nil;
+    if FSlotCount > 1 then
+      Next := @FSlots^[FSlotCount - 2];
+    Data := nil;
+    Index := FSlotCount - 1;
+  end;
+end;
+
+destructor TCache.Destroy;
+begin
+  FreeMem(FSlots);
+  inherited Destroy;
+end;
+
+function TCache.Add(AData: Pointer): Integer;
+var
+  Slot: PCacheSlot;
+begin
+  Slot := FindSlot(AData);
+  if Assigned(Slot) then
+  begin
+    MRUSlot := Slot;
+    Result := Slot^.Index;
+  end else
+    Result := AddNew(AData);
+end;
+
+function TCache.AddNew(AData: Pointer): Integer;
+begin
+  if Assigned(OnFreeSlot) then
+    OnFreeSlot(Self, LRUSlot^.Index);
+  MRUSlot := LRUSlot;
+  MRUSlot^.Data := AData;
+  Result := MRUSlot^.Index;
+end;
+
+function TCache.FindSlot(AData: Pointer): PCacheSlot;
+begin
+  ASSERT((SlotCount = 0) or Assigned(OnIsDataEqual));
+  Result := MRUSlot;
+  while Assigned(Result) do
+  begin
+    if OnIsDataEqual(Self, Result^.Data, AData) then
+      exit;
+    Result := Result^.Next;
+  end;
+end;
+
+function TCache.IndexOf(AData: Pointer): Integer;
+var
+  Slot: PCacheSlot;
+begin
+  ASSERT((SlotCount = 0) or Assigned(OnIsDataEqual));
+  Slot := MRUSlot;
+  while Assigned(Slot) do
+  begin
+    if OnIsDataEqual(Self, Slot^.Data, AData) then
+    begin
+      Result := Slot^.Index;
+      exit;
+    end;
+    Slot := Slot^.Next;
+  end;
+  Slot := -1;
+end;
+
+procedure TCache.Remove(AData: Pointer);
+var
+  Slot: PCacheSlot;
+begin
+  Slot := FindSlot(AData);
+  if Assigned(Slot) then
+    Slot^.Data := nil;
+end;
+
+
+end.
+
+
+{
+  $Log$
+  Revision 1.1  2000-05-16 07:56:02  sg
+  * Initial version
+
+}

fcl/tests/cachetest.pp

@@ -0,0 +1,160 @@
+{
+    $Id$
+
+    Test program for the CacheCls unit
+    Copyright (C) 2000 by Sebastian Guenther ([email protected])
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+}
+
+
+program CacheTest;
+
+{$MODE objfpc}
+
+uses Strings, CacheCls;
+
+type
+  TCacheTester = class
+  private
+    TestCache: TCache;
+    function TestCacheIsDataEqual(ACache: TCache; AData1, AData2: Pointer): Boolean;
+    procedure TestCacheFreeSlot(ACache: TCache; SlotIndex: Integer);
+  protected
+    procedure AddString(const s: PChar);
+    procedure DumpCache;
+  public
+    constructor Create;
+    destructor Destroy; override;
+    procedure Run;
+  end;
+
+
+
+function TCacheTester.TestCacheIsDataEqual(ACache: TCache;
+  AData1, AData2: Pointer): Boolean;
+begin
+  if (not Assigned(AData1)) or (not Assigned(AData2)) then
+    Result := (not Assigned(AData1)) and (not Assigned(AData2))
+  else
+    Result := StrComp(PChar(AData1), PChar(AData2)) = 0;
+end;
+
+procedure TCacheTester.TestCacheFreeSlot(ACache: TCache; SlotIndex: Integer);
+var
+  p: PChar;
+begin
+  Write('  Cache slot #', SlotIndex, ' has been freed (content: ');
+  p := PChar(ACache.Slots[SlotIndex]^.Data);
+  if Assigned(p) then
+    WriteLn('"', p, '")')
+  else
+    WriteLn('nil)');
+end;
+
+procedure TCacheTester.AddString(const s: PChar);
+var
+  i: Integer;
+begin
+  WriteLn('Adding string "', s, '"...');
+  i := TestCache.Add(Pointer(s));
+  WriteLn('string got cache index #', i);
+  WriteLn('New cache state:');
+  DumpCache;
+  WriteLn;
+end;
+
+procedure TCacheTester.DumpCache;
+var
+  Slot, PrevSlot: PCacheSlot;
+begin
+  Slot := TestCache.MRUSlot;
+  PrevSlot := nil;
+  while Assigned(Slot) do
+  begin
+    Write('  Slot #', Slot^.Index, '  ');
+    if Assigned(Slot^.Data) then
+      Write('"', PChar(Slot^.Data), '"')
+    else
+      Write('nil');
+    if Slot^.Prev <> PrevSlot then
+    begin
+      Write('  Slot^.Prev is invalid! (');
+      if Assigned(Slot^.Prev) then
+        Write('points to #', Slot^.Prev^.Index)
+      else
+        Write('nil');
+      Write(')');
+    end;
+    WriteLn;
+    PrevSlot := Slot;
+    Slot := Slot^.Next;
+  end;
+end;
+
+constructor TCacheTester.Create;
+begin
+  inherited Create;
+  TestCache := TCache.Create(4);
+  TestCache.OnIsDataEqual := @TestCacheIsDataEqual;
+  TestCache.OnFreeSlot := @TestCacheFreeSlot;
+
+  WriteLn('Initial cache state:');
+  DumpCache;
+  WriteLn;
+end;
+
+destructor TCacheTester.Destroy;
+begin
+  TestCache.Free;
+  inherited Destroy;
+end;
+
+procedure TCacheTester.Run;
+begin
+  AddString('1st');
+  AddString('2nd');
+  AddString('3rd');
+  AddString('4th');
+  AddString('5th');
+  AddString('3rd');
+  AddString('2nd');
+  WriteLn('Setting slot count to 2...');
+  TestCache.SlotCount := 2;
+  WriteLn('Cache state after resize:');
+  DumpCache;
+  WriteLn;
+  AddString('4th');
+  WriteLn('Setting slot count to 6...');
+  TestCache.SlotCount := 6;
+  WriteLn('Cache state after resize:');
+  DumpCache;
+  WriteLn;
+  AddString('5th');
+  AddString('6th');
+  AddString('7th');
+  AddString('8th');
+end;
+
+
+var
+  CacheTester: TCacheTester;
+
+begin
+  CacheTester := TCacheTester.Create;
+  CacheTester.Run;
+  CacheTester.Free;
+end.
+
+
+{
+  $Log$
+  Revision 1.1  2000-05-16 07:56:02  sg
+  * Initial version
+
+}