tpsystools_4.04/source/StDict.pas

// Upgraded to Delphi 2009: Sebastian Zierer

(* ***** BEGIN LICENSE BLOCK *****
 * Version: MPL 1.1
 *
 * The contents of this file are subject to the Mozilla Public License Version
 * 1.1 (the "License"); you may not use this file except in compliance with
 * the License. You may obtain a copy of the License at
 * http://www.mozilla.org/MPL/
 *
 * Software distributed under the License is distributed on an "AS IS" basis,
 * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
 * for the specific language governing rights and limitations under the
 * License.
 *
 * The Original Code is TurboPower SysTools
 *
 * The Initial Developer of the Original Code is
 * TurboPower Software
 *
 * Portions created by the Initial Developer are Copyright (C) 1996-2002
 * the Initial Developer. All Rights Reserved.
 *
 * Contributor(s):
 *
 * ***** END LICENSE BLOCK ***** *)

{*********************************************************}
{* SysTools: StDict.pas 4.04                             *}
{*********************************************************}
{* SysTools: Dictionary class                            *}
{*********************************************************}

{$I StDefine.inc}

{Notes:
  Nodes stored in the dictionary must be of type TStDictNode.

  Duplicate strings are not allowed in the dictionary.

  Calling Exists moves the found node to the front of its hash bin list.

  Iterate scans the nodes in hash order.

  Hashing and comparison is case-insensitive by default.

  In 16-bit mode, HashSize must be in the range 1..16380. In 32-bit
  mode, there is no practical limit on HashSize. A particular value
  of HashSize may lead to a better distribution of symbols in the
  dictionary, and therefore to better performance. Generally HashSize
  should be about the same size as the number of symbols expected in
  the dictionary. A prime number tends to give a better distribution.
  Based on analysis by D. Knuth, the following values are good
  choices for HashSize when the dictionary keys are alphanumeric
  strings:

    59 61 67 71 73 127 131 137 191 193 197 199 251 257 263 311 313
   317 379 383 389 439 443 449 457 503 509 521 569 571 577 631 641
   643 647 701 709 761 769 773 823 827 829 839 887 953 967

  Good values for larger tables can be computed by the GOODHASH.PAS
  bonus program.
}

unit StDict;

interface

uses
  Windows, SysUtils, Classes,
  StConst, StBase;

type
  TStDictNode = class(TStNode)
{.Z+}
    protected
      dnNext : TStDictNode;     {Next node in hash list}
      dnName : string;          {Name of symbol, already a pointer}
      function GetName : string;

{.Z-}
    public
      constructor CreateStr(const Name : string; AData : Pointer);
        {-Initialize node}
      destructor Destroy; override;
        {-Free name string and destroy node}

      property Name : string
         read GetName;
  end;

{.Z+}
  TSymbolArray = array[0..(StMaxBlockSize div SizeOf(TStDictNode))-1] of TStDictNode;
  PSymbolArray = ^TSymbolArray;
{.Z-}

  TDictHashFunc =
    function(const S : AnsiString; Size : Integer) : Integer;

  TStDictionary = class(TStContainer)
{.Z+}
  protected
    {property instance variables}
    FHashSize : Integer;            {Bins in symbol array}
    FEqual    : TStringCompareFunc; {String compare function}
    FHash     : TDictHashFunc;

    {event variables}
    FOnEqual  : TStStringCompareEvent;

    {private instance variables}
    dySymbols : PSymbolArray;     {Pointer to symbol array}
    dyIgnoreDups : Boolean;       {Ignore duplicates during Join?}

    {protected undocumented methods}
    procedure dySetEqual(E : TStringCompareFunc);
    procedure dySetHash(H : TDictHashFunc);
    procedure dySetHashSize(Size : Integer);
    procedure dyFindNode(const Name : string; var H : Integer;
                         var Prev, This : TStDictNode);
{.Z-}
  public
    constructor Create(AHashSize : Integer); virtual;
      {-Initialize an empty dictionary}
    destructor Destroy; override;
      {-Destroy a dictionary}

    procedure LoadFromStream(S : TStream); override;
      {-Read a dictionary and its data from a stream}
    procedure StoreToStream(S : TStream); override;
      {-Write a dictionary and its data to a stream}

    procedure Clear; override;
      {-Remove all nodes from container but leave it instantiated}
    function DoEqual(const String1, String2 : string) : Integer;
      virtual;
    function Exists(const Name : string; var Data : Pointer) : Boolean;
      {-Return True and the Data pointer if Name is in the dictionary}
    procedure Add(const Name : string; Data : Pointer);
      {-Add new Name and Data to the dictionary}
    procedure Delete(const Name : string);
      {-Delete a Name from the dictionary}
    procedure GetItems(S : TStrings);
      {-Fill the string list with all stored strings}
    procedure SetItems(S : TStrings);
      {-Fill the container with the strings and objects in S}
    procedure Update(const Name : string; Data : Pointer);
      {-Update the data for an existing element}
    function Find(Data : Pointer; var Name : string) : Boolean;
      {-Return True and the element Name that matches Data}

    procedure Assign(Source: TPersistent); override;
      {-Assign another container's contents to this one}
    procedure Join(D : TStDictionary; IgnoreDups : Boolean);
      {-Add dictionary D into this one and dispose D}

    function Iterate(Action : TIterateFunc;
                     OtherData : Pointer) : TStDictNode;
      {-Call Action for all the nodes, returning the last node visited}

    function BinCount(H : Integer) : LongInt;
      {-Return number of names in a hash bin (for testing)}

    property Equal : TStringCompareFunc
      read FEqual
      write dySetEqual;

    property Hash : TDictHashFunc
      read FHash
      write dySetHash;

    property HashSize : Integer
      read FHashSize
      write dySetHashSize;

    property OnEqual : TStStringCompareEvent
      read FOnEqual
      write FOnEqual;
  end;


function AnsiHashText(const S : AnsiString; Size : Integer) : Integer;
  {-Case-insensitive hash function that uses the current language driver}
function AnsiHashStr(const S : AnsiString; Size : Integer) : Integer;
  {-Case-sensitive hash function}
function AnsiELFHashText(const S : AnsiString; Size : Integer) : Integer;
  {-Case-insensitive ELF hash function that uses the current language driver}
function AnsiELFHashStr(const S : AnsiString; Size : Integer) : Integer;
  {-Case-sensitive ELF hash function}


implementation

{$IFDEF UNICODE}
uses
  AnsiStrings;
{$ENDIF}

{$IFDEF ThreadSafe}
var
  ClassCritSect : TRTLCriticalSection;
{$ENDIF}

procedure EnterClassCS;
begin
{$IFDEF ThreadSafe}
  EnterCriticalSection(ClassCritSect);
{$ENDIF}
end;

procedure LeaveClassCS;
begin
{$IFDEF ThreadSafe}
  LeaveCriticalSection(ClassCritSect);
{$ENDIF}
end;


{The following routine was extracted from LockBox and modified}
function HashElf(const Buf;  BufSize : LongInt) : LongInt;
var
//  Bytes : TByteArray absolute Buf;                                   {!!.02}
  Bytes : PAnsiChar;                                                       {!!.02}
  I, X  : LongInt;
begin
  Bytes := @Buf;                                                       {!!.02}
  Result := 0;
  for I := 0 to BufSize - 1 do begin
    Result := (Result shl 4) + Ord(Bytes^);                            {!!.02}
    Inc(Bytes);                                                        {!!.02}
    X := LongInt(Result and $F0000000);                                {!!.02}
    if (X <> 0) then
      Result := Result xor (X shr 24);
    Result := Result and (not X);
  end;
end;

function AnsiELFHashText(const S : AnsiString; Size : Integer) : Integer;
begin
  {$IFDEF WStrings}
  Result := AnsiELFHashStr(AnsiUpperCaseShort32(S), Size);
  {$ELSE}
  Result := AnsiELFHashStr(AnsiUpperCase(S), Size);
  {$ENDIF}
end;

function AnsiELFHashStr(const S : AnsiString; Size : Integer) : Integer;
begin
  Result := HashElf(S[1], Length(S)) mod Size;
  if Result < 0 then
    Inc(Result, Size);
end;

constructor TStDictNode.CreateStr(const Name : string; AData : Pointer);
begin
  Create(AData);
  dnName := Name;
end;

destructor TStDictNode.Destroy;
begin
  dnName := '';
  inherited Destroy;
end;

function TStDictNode.GetName : string;
begin
  Result := dnName;
end;

function AnsiHashStr(const S : AnsiString; Size : Integer) : Integer;
  {32-bit huge string}
register;
asm
  push ebx
  push esi
  push edi
  mov esi,S
  mov edi,Size
  xor ebx,ebx      {ebx will be hash}
  or esi,esi       {empty literal string comes in as a nil pointer}
  jz @2
  mov edx,[esi-4]  {edx = length}
  or edx,edx       {length zero?}
  jz @2
  xor ecx,ecx      {ecx is shift counter}
@1:xor eax,eax
  mov al,[esi]     {eax = character}
  inc esi
  rol eax,cl       {rotate character}
  xor ebx,eax      {xor with hash}
  inc ecx          {increment shift counter (rol uses only bottom 5 bits)}
  dec edx
  jnz @1
@2:mov eax,ebx
  xor edx,edx
  div edi          {edi = Size}
  mov eax,edx      {return hash mod size}
  pop edi
  pop esi
  pop ebx
end;

function AnsiHashText(const S : AnsiString; Size : Integer) : Integer;
begin
{$IFDEF WStrings}
  Result := AnsiHashStr(AnsiUpperCaseShort32(S), Size);
{$ELSE}
  Result := AnsiHashStr(AnsiUpperCase(S), Size);
{$ENDIF}
end;

function FindNodeData(Container : TStContainer;
                      Node : TStNode;
                      OtherData : Pointer) : Boolean; far;
begin
  Result := (OtherData <> Node.Data);
end;

function JoinNode(Container : TStContainer;
                  Node : TStNode;
                  OtherData : Pointer) : Boolean; far;
var
  H : Integer;
  P, T : TStDictNode;
begin
  Result := True;
  with TStDictionary(OtherData) do begin
    dyFindNode(TStDictNode(Node).dnName, H, P, T);
    if Assigned(T) then
      if dyIgnoreDups then begin
        Node.Free;
        Exit;
      end else
        RaiseContainerError(stscDupNode);
    T := dySymbols^[H];
    dySymbols^[H] := TStDictNode(Node);
    dySymbols^[H].dnNext := T;
    Inc(FCount);
  end;
end;

function AssignNode(Container : TStContainer;
                    Node : TStNode;
                    OtherData : Pointer) : Boolean; far;
  var
    DictNode : TStDictNode absolute Node;
    OurDict : TStDictionary absolute OtherData;
  begin
    OurDict.Add(DictNode.Name, DictNode.Data);
    Result := true;
  end;

{----------------------------------------------------------------------}

procedure TStDictionary.Add(const Name : string; Data : Pointer);
var
  H : Integer;
  P, T : TStDictNode;
begin
{$IFDEF ThreadSafe}
  EnterCS;
  try
{$ENDIF}
    dyFindNode(Name, H, P, T);
    if Assigned(T) then
      RaiseContainerError(stscDupNode);
    T := dySymbols^[H];
    dySymbols^[H] := TStDictNode.CreateStr(Name, Data);
    dySymbols^[H].dnNext := T;
    Inc(FCount);
{$IFDEF ThreadSafe}
  finally
    LeaveCS;
  end;
{$ENDIF}
end;

procedure TStDictionary.Assign(Source: TPersistent);
  var
    i : integer;
  begin
    {The only two containers that we allow to be assigned to a string
     dictionary are (1) another string dictionary and (2) a Delphi string
     list (TStrings)}
    if (Source is TStDictionary) then
      begin
        Clear;
        TStDictionary(Source).Iterate(AssignNode, Self);
      end
    else if (Source is TStrings) then
      begin
        Clear;
        for i := 0 to pred(TStrings(Source).Count) do
          Add(TStrings(Source).Strings[i], TStrings(Source).Objects[i]);
      end
    else
      inherited Assign(Source);
  end;

function TStDictionary.BinCount(H : Integer) : LongInt;
var
  C : LongInt;
  T : TStDictNode;
begin
{$IFDEF ThreadSafe}
  EnterCS;
  try
{$ENDIF}
    C := 0;
    T := dySymbols^[H];
    while Assigned(T) do begin
      inc(C);
      T := T.dnNext;
    end;
    Result := C;
{$IFDEF ThreadSafe}
  finally
    LeaveCS;
  end;
{$ENDIF}
end;

procedure TStDictionary.Clear;
begin
{$IFDEF ThreadSafe}
  EnterCS;
  try
{$ENDIF}
    if FCount <> 0 then begin
      Iterate(DestroyNode, nil);
      FCount := 0;
      FillChar(dySymbols^, LongInt(FHashSize)*SizeOf(TStDictNode), 0);
    end;
{$IFDEF ThreadSafe}
  finally
    LeaveCS;
  end;
{$ENDIF}
end;

constructor TStDictionary.Create(AHashSize : Integer);
begin
  CreateContainer(TStDictNode, 0);
  {FHashSize := 0;}
{$IFDEF WStrings}
  FEqual := AnsiCompareTextShort32;
{$ELSE}
  FEqual := AnsiCompareText;
{$ENDIF}
  FHash := AnsiHashText;
  HashSize := AHashSize;
end;

procedure TStDictionary.Delete(const Name : string);
var
  H : Integer;
  P, T : TStDictNode;
begin
{$IFDEF ThreadSafe}
  EnterCS;
  try
{$ENDIF}
    dyFindNode(Name, H, P, T);
    if Assigned(T) then begin
      if Assigned(P) then
        P.dnNext := T.dnNext
      else
        dySymbols^[H] := T.dnNext;
      DestroyNode(Self, T, nil);
      Dec(FCount);
    end;
{$IFDEF ThreadSafe}
  finally
    LeaveCS;
  end;
{$ENDIF}
end;

destructor TStDictionary.Destroy;
begin
  if conNodeProt = 0 then
    Clear;
  if Assigned(dySymbols) then
    FreeMem(dySymbols, LongInt(FHashSize)*SizeOf(TStDictNode));
  IncNodeProtection;
  inherited Destroy;
end;

function TStDictionary.DoEqual(const String1, String2 : string) : Integer;
begin
  Result := 0;
  if Assigned(FOnEqual) then
    FOnEqual(Self, String1, String2, Result)
  else if Assigned(FEqual) then
    Result := FEqual(String1, String2);
end;

procedure TStDictionary.dyFindNode(const Name : string; var H : Integer;
                                   var Prev, This : TStDictNode);
var
  P, T : TStDictNode;
begin
  Prev := nil;
  This := nil;
  H := Hash(Name, HashSize);
  T := dySymbols^[H];
  P := nil;
  while Assigned(T) do begin
    if DoEqual(Name, T.dnName) = 0 then begin
      Prev := P;
      This := T;
      Exit;
    end;
    P := T;
    T := T.dnNext;
  end;

  {Not found}
  This := nil;
end;

procedure TStDictionary.dySetEqual(E : TStringCompareFunc);
begin
{$IFDEF ThreadSafe}
  EnterCS;
  try
{$ENDIF}
    if Count = 0 then
      FEqual := E;
{$IFDEF ThreadSafe}
  finally
    LeaveCS;
  end;
{$ENDIF}
end;

procedure TStDictionary.dySetHash(H : TDictHashFunc);
begin
{$IFDEF ThreadSafe}
  EnterCS;
  try
{$ENDIF}
    if Count = 0 then
      FHash := H;
{$IFDEF ThreadSafe}
  finally
    LeaveCS;
  end;
{$ENDIF}
end;

procedure TStDictionary.dySetHashSize(Size : Integer);
var
  H, OldSize :  Integer;
  TableSize : LongInt;
  T, N : TStDictNode;
  OldSymbols : PSymbolArray;
  OldDisposeData : TDisposeDataProc;
  OldOnDisposeData : TStDisposeDataEvent;
begin
{$IFDEF ThreadSafe}
  EnterCS;
  try
{$ENDIF}
    TableSize := LongInt(Size)*SizeOf(TStDictNode);
    if (Size <= 0) {or (TableSize > MaxBlockSize)} then
      RaiseContainerError(stscBadSize);

    if Size <> FHashSize then begin
      OldSymbols := dySymbols;
      OldSize := FHashSize;

      {Get a new hash table}
      GetMem(dySymbols, TableSize);
      FillChar(dySymbols^, TableSize, 0);
      FCount := 0;
      FHashSize := Size;

      if OldSize <> 0 then begin
        {Prevent disposing of the user data while transferring elements}
        OldDisposeData := DisposeData;
        DisposeData := nil;
        OldOnDisposeData := OnDisposeData;
        OnDisposeData := nil;
        {Add old symbols into new hash table}
        for H := 0 to OldSize-1 do begin
          T := OldSymbols^[H];
          while Assigned(T) do begin
            Add(T.dnName, T.Data);
            N := T.dnNext;
            {free the node just transferred}
            T.Free;
            T := N;
          end;
        end;
        {Dispose of old hash table}
        FreeMem(OldSymbols, OldSize*SizeOf(TStDictNode));
        {Reassign the dispose data routine}
        DisposeData := OldDisposeData;
        OnDisposeData := OldOnDisposeData;
      end;

      {FHashSize := Size;}
    end;
{$IFDEF ThreadSafe}
  finally
    LeaveCS;
  end;
{$ENDIF}
end;

function TStDictionary.Exists(const Name : String; var Data : Pointer) : Boolean;
var
  H : Integer;
  P, T : TStDictNode;
begin
{$IFDEF ThreadSafe}
  EnterCS;
  try
{$ENDIF}
    dyFindNode(Name, H, P, T);
    if Assigned(T) then begin
      if Assigned(P) then begin
        {Move T to front of list}
        P.dnNext := T.dnNext;
        T.dnNext := dySymbols^[H];
        dySymbols^[H] := T;
      end;
      Result := True;
      Data := T.Data;
    end else
      Result := False;
{$IFDEF ThreadSafe}
  finally
    LeaveCS;
  end;
{$ENDIF}
end;

function TStDictionary.Find(Data : Pointer; var Name : string) : Boolean;
var
  T : TStDictNode;
begin
  Name := '';
{$IFDEF ThreadSafe}
  EnterCS;
  try
{$ENDIF}
    T := Iterate(FindNodeData, Data);
    if Assigned(T) then begin
      Result := True;
      Name := T.dnName;
    end else
      Result := False;
{$IFDEF ThreadSafe}
  finally
    LeaveCS;
  end;
{$ENDIF}
end;

procedure TStDictionary.GetItems(S : TStrings);
var
  H : Integer;
  T : TStDictNode;
begin
  S.Clear;
{$IFDEF ThreadSafe}
  EnterCS;
  try
{$ENDIF}
    if FCount <> 0 then begin
      for H := 0 to FHashSize-1 do begin
        T := dySymbols^[H];
        while Assigned(T) do begin
          S.AddObject(T.Name, T.Data);
          T := T.dnNext;
        end;
      end;
    end;
{$IFDEF ThreadSafe}
  finally
    LeaveCS;
  end;
{$ENDIF}
end;

procedure TStDictionary.SetItems(S : TStrings);
var
  I : Integer;
begin
{$IFDEF ThreadSafe}
  EnterCS;
  try
{$ENDIF}
    Clear;
    for I := 0 to S.Count-1 do
      Add(S.Strings[I], S.Objects[I]);
{$IFDEF ThreadSafe}
  finally
    LeaveCS;
  end;
{$ENDIF}
end;

function TStDictionary.Iterate(Action : TIterateFunc;
                               OtherData : Pointer) : TStDictNode;
var
  H    : Integer;
  T, N : TStDictNode;
begin
{$IFDEF ThreadSafe}
  EnterCS;
  try
{$ENDIF}
    if FCount <> 0 then begin
      for H := 0 to FHashSize-1 do begin
        T := dySymbols^[H];
        while Assigned(T) do begin
          N := T.dnNext;
          if Action(Self, T, OtherData) then
            T := N
          else begin
            Result := T;
            Exit;
          end;
        end;
      end;
    end;
    Result := nil;
{$IFDEF ThreadSafe}
  finally
    LeaveCS;
  end;
{$ENDIF}
end;

procedure TStDictionary.Join(D : TStDictionary; IgnoreDups : Boolean);
begin
{$IFDEF ThreadSafe}
  EnterClassCS;
  EnterCS;
  D.EnterCS;
  try
{$ENDIF}
    dyIgnoreDups := IgnoreDups;
    D.Iterate(JoinNode, Self);

    {Dispose of D, but not its nodes}
    D.IncNodeProtection;
    D.Free;
{$IFDEF ThreadSafe}
  finally
    D.LeaveCS;
    LeaveCS;
    LeaveClassCS;
  end;
{$ENDIF}
end;

procedure TStDictionary.Update(const Name : string; Data : Pointer);
var
  H : Integer;
  P, T : TStDictNode;
begin
{$IFDEF ThreadSafe}
  EnterCS;
  try
{$ENDIF}
    dyFindNode(Name, H, P, T);
    if Assigned(T) then
      T.Data := Data;
{$IFDEF ThreadSafe}
  finally
    LeaveCS;
  end;
{$ENDIF}
end;

procedure TStDictionary.LoadFromStream(S : TStream);
var
  Data : pointer;
  Reader : TReader;
  StreamedClass : TPersistentClass;
  StreamedNodeClass : TPersistentClass;
  StreamedClassName : string;
  StreamedNodeClassName : string;
  St : string;
begin
{$IFDEF ThreadSafe}
  EnterCS;
  try
{$ENDIF}
    Clear;
    Reader := TReader.Create(S, 1024);
    try
      with Reader do
        begin
          StreamedClassName := ReadString;
          StreamedClass := GetClass(StreamedClassName);
          if (StreamedClass = nil) then
            RaiseContainerErrorFmt(stscUnknownClass, [StreamedClassName]);
          if (StreamedClass <> Self.ClassType) then
            RaiseContainerError(stscWrongClass);
          StreamedNodeClassName := ReadString;
          StreamedNodeClass := GetClass(StreamedNodeClassName);
          if (StreamedNodeClass = nil) then
            RaiseContainerErrorFmt(stscUnknownNodeClass, [StreamedNodeClassName]);
          if (StreamedNodeClass <> conNodeClass) then
            RaiseContainerError(stscWrongNodeClass);
          HashSize := ReadInteger;
          ReadListBegin;
          while not EndOfList do
            begin
              St := ReadString;
              Data := DoLoadData(Reader);
              Add(St, Data);
            end;
          ReadListEnd;
        end;
    finally
      Reader.Free;
    end;
{$IFDEF ThreadSafe}
  finally
    LeaveCS;
  end;
{$ENDIF}
end;

procedure TStDictionary.StoreToStream(S : TStream);
var
  H      : Integer;
  Walker : TStDictNode;
  Writer : TWriter;
begin
{$IFDEF ThreadSafe}
  EnterCS;
  try
{$ENDIF}
    Writer := TWriter.Create(S, 1024);
    try
      with Writer do
        begin
          WriteString(Self.ClassName);
          WriteString(conNodeClass.ClassName);
          WriteInteger(HashSize);
          WriteListBegin;
          if (Count <> 0) then
            for H := 0 to FHashSize-1 do
              begin
                Walker := dySymbols^[H];
                while Assigned(Walker) do
                  begin
                    WriteString(Walker.dnName);
                    DoStoreData(Writer, Walker.Data);
                    Walker := Walker.dnNext;
                  end;
              end;
          WriteListEnd;
        end;
    finally
      Writer.Free;
    end;
{$IFDEF ThreadSafe}
  finally
    LeaveCS;
  end;
{$ENDIF}
end;

{$IFDEF ThreadSafe}
initialization
  Windows.InitializeCriticalSection(ClassCritSect);
finalization
  Windows.DeleteCriticalSection(ClassCritSect);
{$ENDIF}
end.
1	torben	2671	// Upgraded to Delphi 2009: Sebastian Zierer
2
3			(* *** BEGIN LICENSE BLOCK ***
4			* Version: MPL 1.1
5			*
6			* The contents of this file are subject to the Mozilla Public License Version
7			* 1.1 (the "License"); you may not use this file except in compliance with
8			* the License. You may obtain a copy of the License at
9			* http://www.mozilla.org/MPL/
10			*
11			* Software distributed under the License is distributed on an "AS IS" basis,
12			* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
13			* for the specific language governing rights and limitations under the
14			* License.
15			*
16			* The Original Code is TurboPower SysTools
17			*
18			* The Initial Developer of the Original Code is
19			* TurboPower Software
20			*
21			* Portions created by the Initial Developer are Copyright (C) 1996-2002
22			* the Initial Developer. All Rights Reserved.
23			*
24			* Contributor(s):
25			*
26			* *** END LICENSE BLOCK *** *)
27
28			{*********************************************************}
29			{* SysTools: StDict.pas 4.04 *}
30			{*********************************************************}
31			{* SysTools: Dictionary class *}
32			{*********************************************************}
33
34			{$I StDefine.inc}
35
36			{Notes:
37			Nodes stored in the dictionary must be of type TStDictNode.
38
39			Duplicate strings are not allowed in the dictionary.
40
41			Calling Exists moves the found node to the front of its hash bin list.
42
43			Iterate scans the nodes in hash order.
44
45			Hashing and comparison is case-insensitive by default.
46
47			In 16-bit mode, HashSize must be in the range 1..16380. In 32-bit
48			mode, there is no practical limit on HashSize. A particular value
49			of HashSize may lead to a better distribution of symbols in the
50			dictionary, and therefore to better performance. Generally HashSize
51			should be about the same size as the number of symbols expected in
52			the dictionary. A prime number tends to give a better distribution.
53			Based on analysis by D. Knuth, the following values are good
54			choices for HashSize when the dictionary keys are alphanumeric
55			strings:
56
57			59 61 67 71 73 127 131 137 191 193 197 199 251 257 263 311 313
58			317 379 383 389 439 443 449 457 503 509 521 569 571 577 631 641
59			643 647 701 709 761 769 773 823 827 829 839 887 953 967
60
61			Good values for larger tables can be computed by the GOODHASH.PAS
62			bonus program.
63			}
64
65			unit StDict;
66
67			interface
68
69			uses
70			Windows, SysUtils, Classes,
71			StConst, StBase;
72
73			type
74			TStDictNode = class(TStNode)
75			{.Z+}
76			protected
77			dnNext : TStDictNode; {Next node in hash list}
78			dnName : string; {Name of symbol, already a pointer}
79			function GetName : string;
80
81			{.Z-}
82			public
83			constructor CreateStr(const Name : string; AData : Pointer);
84			{-Initialize node}
85			destructor Destroy; override;
86			{-Free name string and destroy node}
87
88			property Name : string
89			read GetName;
90			end;
91
92			{.Z+}
93			TSymbolArray = array[0..(StMaxBlockSize div SizeOf(TStDictNode))-1] of TStDictNode;
94			PSymbolArray = ^TSymbolArray;
95			{.Z-}
96
97			TDictHashFunc =
98			function(const S : AnsiString; Size : Integer) : Integer;
99
100			TStDictionary = class(TStContainer)
101			{.Z+}
102			protected
103			{property instance variables}
104			FHashSize : Integer; {Bins in symbol array}
105			FEqual : TStringCompareFunc; {String compare function}
106			FHash : TDictHashFunc;
107
108			{event variables}
109			FOnEqual : TStStringCompareEvent;
110
111			{private instance variables}
112			dySymbols : PSymbolArray; {Pointer to symbol array}
113			dyIgnoreDups : Boolean; {Ignore duplicates during Join?}
114
115			{protected undocumented methods}
116			procedure dySetEqual(E : TStringCompareFunc);
117			procedure dySetHash(H : TDictHashFunc);
118			procedure dySetHashSize(Size : Integer);
119			procedure dyFindNode(const Name : string; var H : Integer;
120			var Prev, This : TStDictNode);
121			{.Z-}
122			public
123			constructor Create(AHashSize : Integer); virtual;
124			{-Initialize an empty dictionary}
125			destructor Destroy; override;
126			{-Destroy a dictionary}
127
128			procedure LoadFromStream(S : TStream); override;
129			{-Read a dictionary and its data from a stream}
130			procedure StoreToStream(S : TStream); override;
131			{-Write a dictionary and its data to a stream}
132
133			procedure Clear; override;
134			{-Remove all nodes from container but leave it instantiated}
135			function DoEqual(const String1, String2 : string) : Integer;
136			virtual;
137			function Exists(const Name : string; var Data : Pointer) : Boolean;
138			{-Return True and the Data pointer if Name is in the dictionary}
139			procedure Add(const Name : string; Data : Pointer);
140			{-Add new Name and Data to the dictionary}
141			procedure Delete(const Name : string);
142			{-Delete a Name from the dictionary}
143			procedure GetItems(S : TStrings);
144			{-Fill the string list with all stored strings}
145			procedure SetItems(S : TStrings);
146			{-Fill the container with the strings and objects in S}
147			procedure Update(const Name : string; Data : Pointer);
148			{-Update the data for an existing element}
149			function Find(Data : Pointer; var Name : string) : Boolean;
150			{-Return True and the element Name that matches Data}
151
152			procedure Assign(Source: TPersistent); override;
153			{-Assign another container's contents to this one}
154			procedure Join(D : TStDictionary; IgnoreDups : Boolean);
155			{-Add dictionary D into this one and dispose D}
156
157			function Iterate(Action : TIterateFunc;
158			OtherData : Pointer) : TStDictNode;
159			{-Call Action for all the nodes, returning the last node visited}
160
161			function BinCount(H : Integer) : LongInt;
162			{-Return number of names in a hash bin (for testing)}
163
164			property Equal : TStringCompareFunc
165			read FEqual
166			write dySetEqual;
167
168			property Hash : TDictHashFunc
169			read FHash
170			write dySetHash;
171
172			property HashSize : Integer
173			read FHashSize
174			write dySetHashSize;
175
176			property OnEqual : TStStringCompareEvent
177			read FOnEqual
178			write FOnEqual;
179			end;
180
181
182			function AnsiHashText(const S : AnsiString; Size : Integer) : Integer;
183			{-Case-insensitive hash function that uses the current language driver}
184			function AnsiHashStr(const S : AnsiString; Size : Integer) : Integer;
185			{-Case-sensitive hash function}
186			function AnsiELFHashText(const S : AnsiString; Size : Integer) : Integer;
187			{-Case-insensitive ELF hash function that uses the current language driver}
188			function AnsiELFHashStr(const S : AnsiString; Size : Integer) : Integer;
189			{-Case-sensitive ELF hash function}
190
191
192			implementation
193
194			{$IFDEF UNICODE}
195			uses
196			AnsiStrings;
197			{$ENDIF}
198
199			{$IFDEF ThreadSafe}
200			var
201			ClassCritSect : TRTLCriticalSection;
202			{$ENDIF}
203
204			procedure EnterClassCS;
205			begin
206			{$IFDEF ThreadSafe}
207			EnterCriticalSection(ClassCritSect);
208			{$ENDIF}
209			end;
210
211			procedure LeaveClassCS;
212			begin
213			{$IFDEF ThreadSafe}
214			LeaveCriticalSection(ClassCritSect);
215			{$ENDIF}
216			end;
217
218
219			{The following routine was extracted from LockBox and modified}
220			function HashElf(const Buf; BufSize : LongInt) : LongInt;
221			var
222			// Bytes : TByteArray absolute Buf; {!!.02}
223			Bytes : PAnsiChar; {!!.02}
224			I, X : LongInt;
225			begin
226			Bytes := @Buf; {!!.02}
227			Result := 0;
228			for I := 0 to BufSize - 1 do begin
229			Result := (Result shl 4) + Ord(Bytes^); {!!.02}
230			Inc(Bytes); {!!.02}
231			X := LongInt(Result and $F0000000); {!!.02}
232			if (X <> 0) then
233			Result := Result xor (X shr 24);
234			Result := Result and (not X);
235			end;
236			end;
237
238			function AnsiELFHashText(const S : AnsiString; Size : Integer) : Integer;
239			begin
240			{$IFDEF WStrings}
241			Result := AnsiELFHashStr(AnsiUpperCaseShort32(S), Size);
242			{$ELSE}
243			Result := AnsiELFHashStr(AnsiUpperCase(S), Size);
244			{$ENDIF}
245			end;
246
247			function AnsiELFHashStr(const S : AnsiString; Size : Integer) : Integer;
248			begin
249			Result := HashElf(S[1], Length(S)) mod Size;
250			if Result < 0 then
251			Inc(Result, Size);
252			end;
253
254			constructor TStDictNode.CreateStr(const Name : string; AData : Pointer);
255			begin
256			Create(AData);
257			dnName := Name;
258			end;
259
260			destructor TStDictNode.Destroy;
261			begin
262			dnName := '';
263			inherited Destroy;
264			end;
265
266			function TStDictNode.GetName : string;
267			begin
268			Result := dnName;
269			end;
270
271			function AnsiHashStr(const S : AnsiString; Size : Integer) : Integer;
272			{32-bit huge string}
273			register;
274			asm
275			push ebx
276			push esi
277			push edi
278			mov esi,S
279			mov edi,Size
280			xor ebx,ebx {ebx will be hash}
281			or esi,esi {empty literal string comes in as a nil pointer}
282			jz @2
283			mov edx,[esi-4] {edx = length}
284			or edx,edx {length zero?}
285			jz @2
286			xor ecx,ecx {ecx is shift counter}
287			@1:xor eax,eax
288			mov al,[esi] {eax = character}
289			inc esi
290			rol eax,cl {rotate character}
291			xor ebx,eax {xor with hash}
292			inc ecx {increment shift counter (rol uses only bottom 5 bits)}
293			dec edx
294			jnz @1
295			@2:mov eax,ebx
296			xor edx,edx
297			div edi {edi = Size}
298			mov eax,edx {return hash mod size}
299			pop edi
300			pop esi
301			pop ebx
302			end;
303
304			function AnsiHashText(const S : AnsiString; Size : Integer) : Integer;
305			begin
306			{$IFDEF WStrings}
307			Result := AnsiHashStr(AnsiUpperCaseShort32(S), Size);
308			{$ELSE}
309			Result := AnsiHashStr(AnsiUpperCase(S), Size);
310			{$ENDIF}
311			end;
312
313			function FindNodeData(Container : TStContainer;
314			Node : TStNode;
315			OtherData : Pointer) : Boolean; far;
316			begin
317			Result := (OtherData <> Node.Data);
318			end;
319
320			function JoinNode(Container : TStContainer;
321			Node : TStNode;
322			OtherData : Pointer) : Boolean; far;
323			var
324			H : Integer;
325			P, T : TStDictNode;
326			begin
327			Result := True;
328			with TStDictionary(OtherData) do begin
329			dyFindNode(TStDictNode(Node).dnName, H, P, T);
330			if Assigned(T) then
331			if dyIgnoreDups then begin
332			Node.Free;
333			Exit;
334			end else
335			RaiseContainerError(stscDupNode);
336			T := dySymbols^[H];
337			dySymbols^[H] := TStDictNode(Node);
338			dySymbols^[H].dnNext := T;
339			Inc(FCount);
340			end;
341			end;
342
343			function AssignNode(Container : TStContainer;
344			Node : TStNode;
345			OtherData : Pointer) : Boolean; far;
346			var
347			DictNode : TStDictNode absolute Node;
348			OurDict : TStDictionary absolute OtherData;
349			begin
350			OurDict.Add(DictNode.Name, DictNode.Data);
351			Result := true;
352			end;
353
354			{----------------------------------------------------------------------}
355
356			procedure TStDictionary.Add(const Name : string; Data : Pointer);
357			var
358			H : Integer;
359			P, T : TStDictNode;
360			begin
361			{$IFDEF ThreadSafe}
362			EnterCS;
363			try
364			{$ENDIF}
365			dyFindNode(Name, H, P, T);
366			if Assigned(T) then
367			RaiseContainerError(stscDupNode);
368			T := dySymbols^[H];
369			dySymbols^[H] := TStDictNode.CreateStr(Name, Data);
370			dySymbols^[H].dnNext := T;
371			Inc(FCount);
372			{$IFDEF ThreadSafe}
373			finally
374			LeaveCS;
375			end;
376			{$ENDIF}
377			end;
378
379			procedure TStDictionary.Assign(Source: TPersistent);
380			var
381			i : integer;
382			begin
383			{The only two containers that we allow to be assigned to a string
384			dictionary are (1) another string dictionary and (2) a Delphi string
385			list (TStrings)}
386			if (Source is TStDictionary) then
387			begin
388			Clear;
389			TStDictionary(Source).Iterate(AssignNode, Self);
390			end
391			else if (Source is TStrings) then
392			begin
393			Clear;
394			for i := 0 to pred(TStrings(Source).Count) do
395			Add(TStrings(Source).Strings[i], TStrings(Source).Objects[i]);
396			end
397			else
398			inherited Assign(Source);
399			end;
400
401			function TStDictionary.BinCount(H : Integer) : LongInt;
402			var
403			C : LongInt;
404			T : TStDictNode;
405			begin
406			{$IFDEF ThreadSafe}
407			EnterCS;
408			try
409			{$ENDIF}
410			C := 0;
411			T := dySymbols^[H];
412			while Assigned(T) do begin
413			inc(C);
414			T := T.dnNext;
415			end;
416			Result := C;
417			{$IFDEF ThreadSafe}
418			finally
419			LeaveCS;
420			end;
421			{$ENDIF}
422			end;
423
424			procedure TStDictionary.Clear;
425			begin
426			{$IFDEF ThreadSafe}
427			EnterCS;
428			try
429			{$ENDIF}
430			if FCount <> 0 then begin
431			Iterate(DestroyNode, nil);
432			FCount := 0;
433			FillChar(dySymbols^, LongInt(FHashSize)*SizeOf(TStDictNode), 0);
434			end;
435			{$IFDEF ThreadSafe}
436			finally
437			LeaveCS;
438			end;
439			{$ENDIF}
440			end;
441
442			constructor TStDictionary.Create(AHashSize : Integer);
443			begin
444			CreateContainer(TStDictNode, 0);
445			{FHashSize := 0;}
446			{$IFDEF WStrings}
447			FEqual := AnsiCompareTextShort32;
448			{$ELSE}
449			FEqual := AnsiCompareText;
450			{$ENDIF}
451			FHash := AnsiHashText;
452			HashSize := AHashSize;
453			end;
454
455			procedure TStDictionary.Delete(const Name : string);
456			var
457			H : Integer;
458			P, T : TStDictNode;
459			begin
460			{$IFDEF ThreadSafe}
461			EnterCS;
462			try
463			{$ENDIF}
464			dyFindNode(Name, H, P, T);
465			if Assigned(T) then begin
466			if Assigned(P) then
467			P.dnNext := T.dnNext
468			else
469			dySymbols^[H] := T.dnNext;
470			DestroyNode(Self, T, nil);
471			Dec(FCount);
472			end;
473			{$IFDEF ThreadSafe}
474			finally
475			LeaveCS;
476			end;
477			{$ENDIF}
478			end;
479
480			destructor TStDictionary.Destroy;
481			begin
482			if conNodeProt = 0 then
483			Clear;
484			if Assigned(dySymbols) then
485			FreeMem(dySymbols, LongInt(FHashSize)*SizeOf(TStDictNode));
486			IncNodeProtection;
487			inherited Destroy;
488			end;
489
490			function TStDictionary.DoEqual(const String1, String2 : string) : Integer;
491			begin
492			Result := 0;
493			if Assigned(FOnEqual) then
494			FOnEqual(Self, String1, String2, Result)
495			else if Assigned(FEqual) then
496			Result := FEqual(String1, String2);
497			end;
498
499			procedure TStDictionary.dyFindNode(const Name : string; var H : Integer;
500			var Prev, This : TStDictNode);
501			var
502			P, T : TStDictNode;
503			begin
504			Prev := nil;
505			This := nil;
506			H := Hash(Name, HashSize);
507			T := dySymbols^[H];
508			P := nil;
509			while Assigned(T) do begin
510			if DoEqual(Name, T.dnName) = 0 then begin
511			Prev := P;
512			This := T;
513			Exit;
514			end;
515			P := T;
516			T := T.dnNext;
517			end;
518
519			{Not found}
520			This := nil;
521			end;
522
523			procedure TStDictionary.dySetEqual(E : TStringCompareFunc);
524			begin
525			{$IFDEF ThreadSafe}
526			EnterCS;
527			try
528			{$ENDIF}
529			if Count = 0 then
530			FEqual := E;
531			{$IFDEF ThreadSafe}
532			finally
533			LeaveCS;
534			end;
535			{$ENDIF}
536			end;
537
538			procedure TStDictionary.dySetHash(H : TDictHashFunc);
539			begin
540			{$IFDEF ThreadSafe}
541			EnterCS;
542			try
543			{$ENDIF}
544			if Count = 0 then
545			FHash := H;
546			{$IFDEF ThreadSafe}
547			finally
548			LeaveCS;
549			end;
550			{$ENDIF}
551			end;
552
553			procedure TStDictionary.dySetHashSize(Size : Integer);
554			var
555			H, OldSize : Integer;
556			TableSize : LongInt;
557			T, N : TStDictNode;
558			OldSymbols : PSymbolArray;
559			OldDisposeData : TDisposeDataProc;
560			OldOnDisposeData : TStDisposeDataEvent;
561			begin
562			{$IFDEF ThreadSafe}
563			EnterCS;
564			try
565			{$ENDIF}
566			TableSize := LongInt(Size)*SizeOf(TStDictNode);
567			if (Size <= 0) {or (TableSize > MaxBlockSize)} then
568			RaiseContainerError(stscBadSize);
569
570			if Size <> FHashSize then begin
571			OldSymbols := dySymbols;
572			OldSize := FHashSize;
573
574			{Get a new hash table}
575			GetMem(dySymbols, TableSize);
576			FillChar(dySymbols^, TableSize, 0);
577			FCount := 0;
578			FHashSize := Size;
579
580			if OldSize <> 0 then begin
581			{Prevent disposing of the user data while transferring elements}
582			OldDisposeData := DisposeData;
583			DisposeData := nil;
584			OldOnDisposeData := OnDisposeData;
585			OnDisposeData := nil;
586			{Add old symbols into new hash table}
587			for H := 0 to OldSize-1 do begin
588			T := OldSymbols^[H];
589			while Assigned(T) do begin
590			Add(T.dnName, T.Data);
591			N := T.dnNext;
592			{free the node just transferred}
593			T.Free;
594			T := N;
595			end;
596			end;
597			{Dispose of old hash table}
598			FreeMem(OldSymbols, OldSize*SizeOf(TStDictNode));
599			{Reassign the dispose data routine}
600			DisposeData := OldDisposeData;
601			OnDisposeData := OldOnDisposeData;
602			end;
603
604			{FHashSize := Size;}
605			end;
606			{$IFDEF ThreadSafe}
607			finally
608			LeaveCS;
609			end;
610			{$ENDIF}
611			end;
612
613			function TStDictionary.Exists(const Name : String; var Data : Pointer) : Boolean;
614			var
615			H : Integer;
616			P, T : TStDictNode;
617			begin
618			{$IFDEF ThreadSafe}
619			EnterCS;
620			try
621			{$ENDIF}
622			dyFindNode(Name, H, P, T);
623			if Assigned(T) then begin
624			if Assigned(P) then begin
625			{Move T to front of list}
626			P.dnNext := T.dnNext;
627			T.dnNext := dySymbols^[H];
628			dySymbols^[H] := T;
629			end;
630			Result := True;
631			Data := T.Data;
632			end else
633			Result := False;
634			{$IFDEF ThreadSafe}
635			finally
636			LeaveCS;
637			end;
638			{$ENDIF}
639			end;
640
641			function TStDictionary.Find(Data : Pointer; var Name : string) : Boolean;
642			var
643			T : TStDictNode;
644			begin
645			Name := '';
646			{$IFDEF ThreadSafe}
647			EnterCS;
648			try
649			{$ENDIF}
650			T := Iterate(FindNodeData, Data);
651			if Assigned(T) then begin
652			Result := True;
653			Name := T.dnName;
654			end else
655			Result := False;
656			{$IFDEF ThreadSafe}
657			finally
658			LeaveCS;
659			end;
660			{$ENDIF}
661			end;
662
663			procedure TStDictionary.GetItems(S : TStrings);
664			var
665			H : Integer;
666			T : TStDictNode;
667			begin
668			S.Clear;
669			{$IFDEF ThreadSafe}
670			EnterCS;
671			try
672			{$ENDIF}
673			if FCount <> 0 then begin
674			for H := 0 to FHashSize-1 do begin
675			T := dySymbols^[H];
676			while Assigned(T) do begin
677			S.AddObject(T.Name, T.Data);
678			T := T.dnNext;
679			end;
680			end;
681			end;
682			{$IFDEF ThreadSafe}
683			finally
684			LeaveCS;
685			end;
686			{$ENDIF}
687			end;
688
689			procedure TStDictionary.SetItems(S : TStrings);
690			var
691			I : Integer;
692			begin
693			{$IFDEF ThreadSafe}
694			EnterCS;
695			try
696			{$ENDIF}
697			Clear;
698			for I := 0 to S.Count-1 do
699			Add(S.Strings[I], S.Objects[I]);
700			{$IFDEF ThreadSafe}
701			finally
702			LeaveCS;
703			end;
704			{$ENDIF}
705			end;
706
707			function TStDictionary.Iterate(Action : TIterateFunc;
708			OtherData : Pointer) : TStDictNode;
709			var
710			H : Integer;
711			T, N : TStDictNode;
712			begin
713			{$IFDEF ThreadSafe}
714			EnterCS;
715			try
716			{$ENDIF}
717			if FCount <> 0 then begin
718			for H := 0 to FHashSize-1 do begin
719			T := dySymbols^[H];
720			while Assigned(T) do begin
721			N := T.dnNext;
722			if Action(Self, T, OtherData) then
723			T := N
724			else begin
725			Result := T;
726			Exit;
727			end;
728			end;
729			end;
730			end;
731			Result := nil;
732			{$IFDEF ThreadSafe}
733			finally
734			LeaveCS;
735			end;
736			{$ENDIF}
737			end;
738
739			procedure TStDictionary.Join(D : TStDictionary; IgnoreDups : Boolean);
740			begin
741			{$IFDEF ThreadSafe}
742			EnterClassCS;
743			EnterCS;
744			D.EnterCS;
745			try
746			{$ENDIF}
747			dyIgnoreDups := IgnoreDups;
748			D.Iterate(JoinNode, Self);
749
750			{Dispose of D, but not its nodes}
751			D.IncNodeProtection;
752			D.Free;
753			{$IFDEF ThreadSafe}
754			finally
755			D.LeaveCS;
756			LeaveCS;
757			LeaveClassCS;
758			end;
759			{$ENDIF}
760			end;
761
762			procedure TStDictionary.Update(const Name : string; Data : Pointer);
763			var
764			H : Integer;
765			P, T : TStDictNode;
766			begin
767			{$IFDEF ThreadSafe}
768			EnterCS;
769			try
770			{$ENDIF}
771			dyFindNode(Name, H, P, T);
772			if Assigned(T) then
773			T.Data := Data;
774			{$IFDEF ThreadSafe}
775			finally
776			LeaveCS;
777			end;
778			{$ENDIF}
779			end;
780
781			procedure TStDictionary.LoadFromStream(S : TStream);
782			var
783			Data : pointer;
784			Reader : TReader;
785			StreamedClass : TPersistentClass;
786			StreamedNodeClass : TPersistentClass;
787			StreamedClassName : string;
788			StreamedNodeClassName : string;
789			St : string;
790			begin
791			{$IFDEF ThreadSafe}
792			EnterCS;
793			try
794			{$ENDIF}
795			Clear;
796			Reader := TReader.Create(S, 1024);
797			try
798			with Reader do
799			begin
800			StreamedClassName := ReadString;
801			StreamedClass := GetClass(StreamedClassName);
802			if (StreamedClass = nil) then
803			RaiseContainerErrorFmt(stscUnknownClass, [StreamedClassName]);
804			if (StreamedClass <> Self.ClassType) then
805			RaiseContainerError(stscWrongClass);
806			StreamedNodeClassName := ReadString;
807			StreamedNodeClass := GetClass(StreamedNodeClassName);
808			if (StreamedNodeClass = nil) then
809			RaiseContainerErrorFmt(stscUnknownNodeClass, [StreamedNodeClassName]);
810			if (StreamedNodeClass <> conNodeClass) then
811			RaiseContainerError(stscWrongNodeClass);
812			HashSize := ReadInteger;
813			ReadListBegin;
814			while not EndOfList do
815			begin
816			St := ReadString;
817			Data := DoLoadData(Reader);
818			Add(St, Data);
819			end;
820			ReadListEnd;
821			end;
822			finally
823			Reader.Free;
824			end;
825			{$IFDEF ThreadSafe}
826			finally
827			LeaveCS;
828			end;
829			{$ENDIF}
830			end;
831
832			procedure TStDictionary.StoreToStream(S : TStream);
833			var
834			H : Integer;
835			Walker : TStDictNode;
836			Writer : TWriter;
837			begin
838			{$IFDEF ThreadSafe}
839			EnterCS;
840			try
841			{$ENDIF}
842			Writer := TWriter.Create(S, 1024);
843			try
844			with Writer do
845			begin
846			WriteString(Self.ClassName);
847			WriteString(conNodeClass.ClassName);
848			WriteInteger(HashSize);
849			WriteListBegin;
850			if (Count <> 0) then
851			for H := 0 to FHashSize-1 do
852			begin
853			Walker := dySymbols^[H];
854			while Assigned(Walker) do
855			begin
856			WriteString(Walker.dnName);
857			DoStoreData(Writer, Walker.Data);
858			Walker := Walker.dnNext;
859			end;
860			end;
861			WriteListEnd;
862			end;
863			finally
864			Writer.Free;
865			end;
866			{$IFDEF ThreadSafe}
867			finally
868			LeaveCS;
869			end;
870			{$ENDIF}
871			end;
872
873			{$IFDEF ThreadSafe}
874			initialization
875			Windows.InitializeCriticalSection(ClassCritSect);
876			finalization
877			Windows.DeleteCriticalSection(ClassCritSect);
878			{$ENDIF}
879			end.