xpkeywords.pas

For Delphi的单元测试工具DUnit的源代码

unit XPKeyWords;

{
 $Source: /cvsroot/dunit/dunit/Contrib/DUnitWizard/Source/DelphiExperts/Common/XPKeyWords.pas,v $
 $Revision: 1.2 $
 $Date: 2004/05/03 15:07:15 $
 Last amended by $Author: pvspain $
 $State: Exp $

 XPKeyWords:

 * TXPKeyWords is a class which provides efficient, case-insensitive
   ObjectPascal reserved word, directive and miscellaneous keyword comparisons.
   See Delphi Help topics "Reserved Words" and "Directives" for more
   information.

 Copyright (c) 2001 by The Excellent Programming Company Pty Ltd
 (ABN 27 005 394 918). All rights reserved. This source code is not to be
 redistributed without prior permission from the copyright holder.

 Contact Paul Spain via email: [e-mail]
 }

interface

type

  TXPResWord = (
    rwAnd, rwArray, rwAs, rwAsm, rwBegin, rwCase, rwClass, rwConst,
    rwConstructor, rwDestructor, rwDispinterface, rwDiv, rwDo, rwDownto,
    rwElse, rwEnd, rwExcept, rwExports, rwFile, rwFinalization, rwFinally,
    rwFor, rwFunction, rwGoto, rwIf, rwImplementation, rwIn, rwInherited,
    rwInitialization, rwInline, rwInterface, rwIs, rwLabel, rwLibrary, rwMod,
    rwNil, rwNot, rwObject, rwOf, rwOr, rwOut, rwPacked, rwProcedure,
    rwProgram, rwProperty, rwRaise, rwRecord, rwRepeat, rwResourcestring,
    rwSet, rwShl, rwShr, rwString, rwThen, rwThreadvar, rwTo, rwTry, rwType,
    rwUnit, rwUntil, rwUses, rwVar, rwWhile, rwWith, rwXor );

  TXPResWords = set of TXPResWord;

  TXPDirective = (
    dAbsolute, dAbstract, dAssembler, dAutomated, dCdecl, dContains, dDefault,
    dDispid, dDynamic, dExport, dExternal, dFar, dForward, dImplements, dIndex,
    dMessage, dName, dNear, dNodefault, dOverload, dOverride, dPackage,
    dPascal, dPrivate, dProtected, dPublic, dPublished, dRead, dReadonly,
    dRegister, dReintroduce, dRequires, dResident, dSafecall, dStdcall,
    dStored, dVirtual, dWrite, dWriteonly );

  TXPDirectives = set of TXPDirective;
  
  TXPMisc = ( mAt, mOn );

  TXPKeyWordKind = ( kwResWord, kwDirective, kwMisc );

  TXPKeyWord = record
    case Kind: TXPKeyWordKind of
      kwResWord: (ResWord: TXPResWord);
      kwDirective: (Directive: TXPDirective);
      kwMisc: (Misc: TXPMisc);
    end;

  TXPKeyWordEntry = record
    Text: string;
    KeyWord: TXPKeyWord;
    end;

  {
    This hash table class implementation uses a double hashing technique for
    insertion and extraction(matching).
    [Ref: Sedgewick, R. 'Algorithms in C' Ch 16: Hashing]
  }

  TXPKeyWords = class(TObject)
    private

    FKeys: array of TXPKeyWordEntry;
    FCount, FHashPrime: integer;

    function Hash(const Key: string): integer;
    function SecondHash(const Key: string): integer;
    procedure Insert(const Key: string; const Kind: TXPKeyWordKind;
      const Index: integer);

    property Count: integer read FCount;
    property Size: integer read FHashPrime;

    public

    constructor Create;
    destructor Destroy; override;
    function Match(Str: string; out KeyWord: TXPKeyWord): boolean;
    class function KeyWordAsText(const KeyWord: TXPKeyWord): string;
    end;


implementation

uses
{$IFDEF XPKEYWORDS_DEBUG}
    KWMain,
{$ENDIF}
    SysUtils;

const
  CVSID: string = '$Header: /cvsroot/dunit/dunit/Contrib/DUnitWizard/Source/DelphiExperts/Common/XPKeyWords.pas,v 1.2 2004/05/03 15:07:15 pvspain Exp $';

const ResWordStrings: array [TXPResWord] of string = (
    'and', 'array', 'as', 'asm', 'begin', 'case', 'class', 'const',
    'constructor', 'destructor', 'dispinterface', 'div', 'do', 'downto',
    'else', 'end', 'except', 'exports', 'file', 'finalization', 'finally',
    'for', 'function', 'goto', 'if', 'implementation', 'in', 'inherited',
    'initialization', 'inline', 'interface', 'is', 'label', 'library', 'mod',
    'nil', 'not', 'object', 'of', 'or', 'out', 'packed', 'procedure',
    'program', 'property', 'raise', 'record', 'repeat', 'resourcestring',
    'set', 'shl', 'shr', 'string','then', 'threadvar', 'to', 'try', 'type',
    'unit', 'until', 'uses', 'var', 'while', 'with', 'xor' );

const DirectiveStrings: array [TXPDirective] of string = (
    'absolute', 'abstract', 'assembler', 'automated', 'cdecl', 'contains',
    'default', 'dispid', 'dynamic', 'export', 'external', 'far', 'forward',
    'implements', 'index', 'message', 'name', 'near', 'nodefault', 'overload',
    'override', 'package', 'pascal', 'private', 'protected', 'public',
    'published', 'read', 'readonly', 'register', 'reintroduce', 'requires',
    'resident', 'safecall', 'stdcall', 'stored', 'virtual', 'write',
    'writeonly' );

const MiscStrings: array [TXPMisc] of string = ( 'at', 'on' );

constructor TXPKeyWords.Create;
  var
  idx, Max: integer;
{$IFDEF XPKEYWORDS_DEBUG}
  jdx : integer;
  KeyWord: TXPKeyWord;
  Matched: boolean;
{$ENDIF}

  begin
  inherited Create;
  FHashPrime := 853;
  System.SetLength(FKeys, FHashPrime);
  Max := System.Ord(High(TXPResWord));

  // Insert reserved keywords
  for idx := 0 to Max do
    Insert(ResWordStrings[TXPResWord(idx)], kwResWord, idx);

  Max := System.Ord(High(TXPDirective));

  // Insert directive keywords
  for idx := 0 to Max do
    Insert(DirectiveStrings[TXPDirective(idx)], kwDirective, idx);

  Max := System.Ord(High(TXPMisc));

  // Insert miscellaneous keywords
  for idx := 0 to Max do
    Insert(MiscStrings[TXPMisc(idx)], kwMisc, idx);

{$IFDEF XPKEYWORDS_DEBUG}
  Form1.HashTable.Lines.Clear;

  for jdx := 0 to FHashPrime - 1 do
    Form1.HashTable.Lines.Add(Format('%3d: %3d %s',
      [jdx, Ord(FKeys[jdx].KeyWord.ResWord), FKeys[jdx].Text]));

  for idx := 0 to Ord(High(TXPResWord)) do
    begin
    Matched := Match(ResWordStrings[TXPResWord(idx)], KeyWord);
    Form1.Log.Lines.Add(Format('%d %s:%s %3d',
      [Ord(Matched), ResWordStrings[TXPResWord(idx)],
        ResWordStrings[KeyWord.ResWord], Ord(KeyWord.ResWord)]));
    end;

  for idx := 0 to Ord(High(TXPDirective)) do
    begin
    Matched := Match(DirectiveStrings[TXPDirective(idx)], KeyWord);
    Form1.Log.Lines.Add(Format('%d %s:%s %3d',
      [Ord(Matched), DirectiveStrings[TXPDirective(idx)],
        DirectiveStrings[KeyWord.Directive], Ord(KeyWord.Directive)]));
    end;

  for idx := 0 to Ord(High(TXPMisc)) do
    begin
    Matched := Match(MiscStrings[TXPMisc(idx)], KeyWord);
    Form1.Log.Lines.Add(Format('%d %s:%s %3d',
      [Ord(Matched), MiscStrings[TXPMisc(idx)], MiscStrings[KeyWord.Misc],
      Ord(KeyWord.Misc)]));
    end;

   Form1.Count.Text := IntToStr(Count);
{$ENDIF}
  end;

destructor TXPKeyWords.Destroy;
   begin
   FKeys := nil;
   inherited Destroy;
   end;

function TXPKeyWords.Hash(const Key: string): integer;
    var
    KeyChar: ^Byte;

    begin
    Result := 0;
    KeyChar := Pointer(Key);

    while KeyChar^ <> 0 do
       begin
       Result := ((Result shl 6) + KeyChar^) mod FHashPrime;
       System.Inc(KeyChar);
       end;

    end;

function TXPKeyWords.SecondHash(const Key: string): integer;
    begin
    { Returns a number in the range 0-8, based on the last 3 bits of <Key> }
    Result := 8 - (System.Ord(Key[System.Length(Key)])) mod 8;
    end;

procedure TXPKeyWords.Insert(const Key: string; const Kind: TXPKeyWordKind;
      const Index: integer);
  var
  idx, offset: integer;
  {$IFDEF XPKEYWORDS_DEBUG}
  Insertlog: string;
  {$ENDIF}

  begin
  { Check for available space. }
  if Count < Size then
    System.Inc(FCount)
  else
    exit;

  { Assume <Key> is always lower-cased. }
  idx := Hash(Key);
  offset := SecondHash(Key);
{$IFDEF XPKEYWORDS_DEBUG}
    Insertlog := Format('%3d:', [Index]);
{$ENDIF}

  { Second condition ensures no duplicate keys in table. }
  while not((System.Length(FKeys[idx].Text) = 0)
    or (SysUtils.AnsiCompareStr(FKeys[idx].Text, Key) = 0)) do
    begin
{$IFDEF XPKEYWORDS_DEBUG}
    Insertlog := Format('%s %3d:%s',
    [InsertLog, idx, FKeys[idx].Text]);
{$ENDIF}
    idx := (idx + offset) mod FHashPrime;
    end;

  FKeys[idx].Text := Key;
  FKeys[idx].KeyWord.Kind := Kind;

  case Kind of
    kwResWord: FKeys[idx].KeyWord.ResWord := TXPResWord(Index);
    kwDirective: FKeys[idx].KeyWord.Directive := TXPDirective(Index);
    kwMisc: FKeys[idx].KeyWord.Misc := TXPMisc(Index);
    end;

{$IFDEF XPKEYWORDS_DEBUG}
  Insertlog := Format('%s %3d:%s'#13#10,
  [InsertLog, idx, FKeys[idx].Text]);
  Form1.Log.Lines.Add(InsertLog);
{$ENDIF}
  end;

function TXPKeyWords.Match(Str: string; out KeyWord: TXPKeyWord): boolean;
    var
    idx, offset: integer;

    begin
    Str := SysUtils.AnsiLowerCase(Str);
    idx := Hash(Str);
    offset := SecondHash(Str);

    { Bail on empty slot or match. }
    while not ((System.Length(FKeys[idx].Text) = 0)
      or (SysUtils.AnsiCompareStr(FKeys[idx].Text, Str) = 0)) do
        idx := (idx + offset) mod FHashPrime;

    { Result = not bailed on miss. }
    Result := not (System.Length(FKeys[idx].Text) = 0);

    if Result then
      KeyWord := FKeys[idx].KeyWord;

    end;

class function TXPKeyWords.KeyWordAsText(const KeyWord: TXPKeyWord): string;
  begin

  case KeyWord.Kind of
    kwResWord:
      Result := ResWordStrings[KeyWord.ResWord];
    kwDirective:
      Result := DirectiveStrings[KeyWord.Directive];
    kwMisc:
      Result := MiscStrings[KeyWord.Misc];
    end;

  end;

end.