unit LexemParser;

interface

uses
  SysUtils, Classes, SyncObjs;

const
  MIN_HASH_SIZE = 57;

  NULL_HASH = $FFFFFFFF;

type
  THashVal = packed record
      Primary: word;
      Secondary: word;
  end;//of record

  THashRec = class
    private
      fLine: string;
      fHash: cardinal;
      fNext: THashRec;
      function GetPrimary: word;
      function GetSecondary: word;
      function GetPLine: PChar;
    protected
      property Next: THashRec read fNext;
    public
      constructor Create(const ALine: string; AHash: cardinal); virtual;
      function ToString: string; virtual;
      property Line: string read fLine;
      property PLine: PChar read GetPLine;
      property Primary: word read GetPrimary;
      property Secondary: word read GetSecondary;
      property Hash: cardinal read fHash;
  end;//of class

  THashRecClass = class of THashRec;

  EBadHashRecordClassPointer = class(Exception);

  THashTable = class
    private
      fRecClass: THashRecClass;
      fSize: integer;
      fTable: array of THashRec;
      function Get(Index: integer): THashRec;
    protected
      function H(const S: string): integer;
      function InTable(const S: string; out H: cardinal; out Rec: THashRec): boolean;
      function HashString(const S: string; out H: cardinal;
                          out Rec: THashRec; Insert: boolean): boolean; overload;
      procedure Remove(const H: cardinal); overload;
      procedure Remove(const S: string); overload;
      function HashString(const S: string): cardinal; overload;
      property Table[Index: integer]: THashRec read Get;
    public
      constructor Create(ASize: integer = MIN_HASH_SIZE; ARecClass: THashRecClass = nil); virtual;
      destructor Destroy; override;
      procedure Clear; virtual;
      procedure LoadFromStrings(Strings: TStrings); virtual;
      function AquireHash(const S: string; out H: cardinal;
                          out Rec: THashRec; Insert: boolean = true): boolean; virtual;
      procedure ReleaseHash(const S: string); overload; virtual;
      procedure ReleaseHash(H: cardinal); overload; virtual;
      procedure ReleaseHash(Rec: THashRec); overload; virtual;
      function ExtractObject(H: cardinal): THashRec; virtual;
      function ExtractString(H: cardinal): string; virtual;
      procedure Print(Lines: TStrings); overload; virtual;
      procedure Print(Stream: TStream); overload; virtual;
      property RecClass: THashRecClass read fRecClass;
      property Size: integer read fSize;
  end;//of class

  EHashTableRange = class(Exception);

  TThreadHashTable = class(THashTable)
    private
      fCritSec: TCriticalSection;
    protected
      property CritSec: TCriticalSection read fCritSec;
    public
      constructor Create(ASize: integer = MIN_HASH_SIZE; ARecClass: THashRecClass = nil); override;
      destructor Destroy; override;
      procedure Clear; override;
      procedure LoadFromStrings(Strings: TStrings); override;
      function AquireHash(const S: string; out H: cardinal;
                          out Rec: THashRec; Insert: boolean = true): boolean; override;
      procedure ReleaseHash(const S: string); overload; override;
      procedure ReleaseHash(H: cardinal); overload; override;
      procedure ReleaseHash(Rec: THashRec); overload; override;
      function ExtractObject(H: cardinal): THashRec; override;
      procedure Print(Stream: TStream); override;
  end;//of class

  function CreateHashTable(ASize: integer = MIN_HASH_SIZE;
                           AHashRecClass: THashRecClass = nil): THashTable;

type
  TLexHashRec = class;
  TLexParser = class;

  TCharKind  = (ckEOL,     //End Of Line - нуль символ #0
                ckSpace,   //пробел, символы конца строки, табуляции
                ckLetter,  //символы букв латиницы и кириллицы плюс _
                ckNumber,  //от 0 до 9
                ckSymbol); //символы знаков + - и т.п.

  TTrigger   = (tgSpace,
                tgIdentifer,
                tgIntNumber,
                tgFloatNumber,
                tgSymbol);

  TLexemKind = (lkUnknown,     //неизвестная лексема
                lkEOL,         //конец строки end-of-line
                lkSpace,       //пробел
                lkKeyWord,     //ключевое слово
                lkIdentifer,   //идентификатор
                lkOptWord,     //необязательное слово
                lkFloatNumber, //вещественное число
                lkIntNumber,   //целое число
                lkOperator);   //оператор (как + или and)

  PLexem = ^TLexem;
  TLexem = packed record
      Pos: word;        //позиция лексемы в строке
      Length: word;     //длина лексемы
      Kind: TLexemKind; //тип лексемы
      Rec: TLexHashRec; //запись из таблицы
  end;//of record

  TLexemStorage = array of TLexem;

  TLexemEvent = procedure (Sender: TLexParser; const Lexem: TLexem) of object;

  PCharArray = ^TCharArray;
  TCharArray = array[1..MaxInt div 2] of Char;

  TWordType = (wtKeyWord, wtOperator, wtOptWord);

  TLexHashRec = class(THashRec)
    private
      fWordType: TWordType;
    public
      property WordType: TWordType read fWordType write fWordType;
  end;//of class

  TLexHashRecClass = class of TLexHashRec;

  TLexParser = class
    private
      fLexHashRecClass: TLexHashRecClass;
      fNullRec: TLexHashRec;
      fLine: PCharArray;
      fLen: integer;
      fCur: integer;
      fOnLexem: TLexemEvent;
      fCharTrigger: array[Low(TCharKind)..High(TCharKind)] of procedure of object;
      fWords: THashTable;
      fEmitSpace: boolean;
      fEmitEOL: boolean;
      fLexStorage: TLexemStorage;
      fStopParsing: boolean;
      procedure RecognizeLexem(Pos,Length: integer; Trigger: TTrigger);
      procedure trigEOL;
      procedure trigSpace;
      procedure trigLetter;
      procedure trigNumber;
      procedure trigSymbol;
      procedure OwnOnLexem(Sender: TLexParser; const Lexem: TLexem);
    protected
      property NullRec: TLexHashRec read fNullRec;
      property Words: THashTable read fWords;
    public
      constructor Create(ALexHashRecClass: TLexHashRecClass = nil);
      destructor Destroy; override;
      procedure ProcessLine(const Line: PChar; Len: integer; OnLexem: TLexemEvent); overload;
      procedure ProcessLine(const Line: PChar; Len: integer; out LexStorage: TLexemStorage); overload;
      procedure StopParsing;
      procedure AddWord(const Word: string; WordType: TWordType);
      procedure ClearWords;
      property EmitSpace: boolean read fEmitSpace write fEmitSpace;
      property EmitEOL: boolean read fEmitEOL write fEmitEOL;
      property LexHashRecClass: TLexHashRecClass read fLexHashRecClass;
  end;//of class

  ELexParserLexHashRecClassError = class(Exception);

  TGuidedParser = class
    private
      fParser: TLexParser;
      fStorage: TLexemStorage;
      fLexCount: integer;
      fLexPos: integer;
      procedure SetLexPos(NewVal: integer);
    public
      constructor Create;
      destructor Destroy; override;
      procedure Init(const Line: PChar; Len: integer);
      function GetLexem(out Lexem: TLexem): boolean;
      property Parser: TLexParser read fParser;
      property LexCount: integer read fLexCount;
      property LexPos: integer read fLexPos write SetLexPos;
  end;//of class

  tagElemType = integer;
  PtagStackPage = ^tagStackPage;
  tagStackPage = array[0..MaxInt div 8] of tagElemType;

  TStackPage = class
    private
      fPage: PtagStackPage;
      fCapacity: integer;
      fCount: integer;
      fHeadPage: integer;
      fHeadOffset: integer;
    protected
      procedure Grow(PlaceCount: integer);
      property HeadPage: integer read fHeadPage write fHeadPage;
      property HeadOffset: integer read fHeadOffset write fHeadOffset;
    public
      constructor Create(AHeadPage, AHeadOffset: integer);
      destructor Destroy; override;
      procedure Clear;
      procedure Add(Value: tagElemType);
      property Page: PtagStackpage read fPage;
      property Capacity: integer read fCapacity;
      property Count: integer read fCount;
  end;

  PtagStack = ^tagStack;
  tagStack = array[0..MaxInt div 8] of TStackPage;

  TMagicStack = class
    private
      fPages: PtagStack;
      fPageCount: integer;
      fCapacity: integer;
      fCurrentPage: integer;
      fStkHead: integer;
      fStkOffset: integer;
      procedure SetPageCount(NewValue: integer);
      procedure SetCurrentPage(NewValue: integer);
      function GetEmpty: boolean;
    protected
      procedure Grow(PlaceCount: integer);
      procedure DisposeLastPages(Count: integer);
      property Capacity: integer read fCapacity;
    public
      constructor Create;
      destructor Destroy; override;
      procedure Clear;
      procedure SelectStkHead(PageIndex: integer);
      procedure Unite; overload;
      procedure Unite(Page1, Page2: integer); overload;
      procedure ResetStkHead;
      procedure CommitStkHead;
      procedure Add(CountPages: integer = 1);
      procedure Push(Value: tagElemType);
      function Pop(out Value: tagElemType): boolean; overload;
      function Pop(out Value: tagElemType;
                   out StkPage, StkOffset: integer): boolean; overload;
      function Top(out Value: tagElemType): boolean; overload;
      function Top(out Value: tagElemType;
                   out StkPage, StkOffset: integer): boolean; overload;
      property PageCount: integer read fPageCount write SetPageCount;
      property CurrentPage: integer read fCurrentPage write SetCurrentPage;
      property Empty: boolean read GetEmpty;
  end;

  EPagedStackError = class(Exception);

const
  LEXEMKIND: array[Low(TLexemKind)..High(TLexemKind)] of string =
                 ('Unknown',
                  'EOL',
                  'Space',
                  'Keyword',
                  'Identifer',
                  'OptWord',
                  'FloatNumber',
                  'IntNumber',
                  'Operator');

  function Lexem(Pos,Length: integer; Kind: TLexemKind; Rec: TLexHashRec): TLexem;

implementation

var
  CHARKIND: array[Low(Char)..High(Char)] of TCharKind;

{ ### THashRec ############################################################### }

constructor THashRec.Create(const ALine: string; AHash: cardinal);
  begin
    fLine:=ALine;
    fHash:=AHash
  end;

  { ### private ### }

function THashRec.GetPrimary: word;
  begin
    Result:=THashVal(fHash).Primary;
  end;

function THashRec.GetSecondary: word;
  begin
    Result:=THashVal(fHash).Secondary;
  end;

function THashRec.GetPLine: PChar;
  begin
    Result:=pointer(fLine);
  end;

  { ### public ### }

function THashRec.ToString: string;
  begin
    Result:=Format('%d.%d: %s'#13#10,[Primary,Secondary,Line]);
  end;

{ ### THashTable ############################################################# }

constructor THashTable.Create(ASize: integer = MIN_HASH_SIZE; ARecClass: THashRecClass = nil);
  begin
    if ARecClass = nil then ARecClass:=THashRec;
    if not ARecClass.InheritsFrom(THashRec) then begin
        raise EBadHashRecordClassPointer.CreateFmt(
                  'Specified class "%s" doesn''t inherits from "%s"',
                  [ARecClass.ClassName,THashRec.ClassName]  );
    end;
    fRecClass:=THashRecClass(ARecClass);
    if ASize<MIN_HASH_SIZE then ASize:=MIN_HASH_SIZE;
    fSize:=ASize;
    SetLength(fTable,fSize);
  end;

destructor THashTable.Destroy;
  begin
    Clear;
    Finalize(fTable);
    inherited;
  end;

  { ### private ### }

function THashTable.Get(Index: integer): THashRec;
  begin
    if Index<0 then raise EHashTableRange.Create('Hash block index subrange');
    if Index>=Size then raise EHashTableRange.Create('Hash block index overrange');
    Result:=fTable[Index]
  end;

  { ### public ### }

procedure THashTable.Clear;
  var i: integer;
      first,tmp: THashRec;
  begin
    for i:=0 to Size-1 do begin
        first:=fTable[i];
        while first<>nil do begin
            tmp:=first.fNext;
            first.Free;
            first:=tmp;
        end;
        fTable[i]:=nil;
    end;
  end;

procedure THashTable.LoadFromStrings(Strings: TStrings);
  var i: integer;
      S: string;
      H: cardinal;
      R: THashRec;
  begin
    if Strings=nil then Exit;
    Clear;
    for i:=0 to Strings.Count-1 do begin
        S:=Trim(Strings.Strings[i]);
        if S<>'' then HashString(S,H,R,true);
    end;
  end;

{ хэш-функция Вайнбергера }
function THashTable.H(const S: string): integer;
  var i: integer;
      tmp,Res: cardinal;
  begin
    Res:=0;
    for i:=1 to Length(S) do begin
        Res:=(Res shl 4) + ord(S[i]);
        tmp:=Res and $F0000000;
        if longbool(tmp) then Res:=Res xor ((tmp shr 24) xor tmp)
    end;
    Result:=(Res mod cardinal(Size));
  end;

function THashTable.InTable(const S: string; out H: cardinal; out Rec: THashRec): boolean;
  begin
    Result:=false;
    THashVal(H).Primary:=Self.H(S);
    THashVal(H).Secondary:=0;
    Rec:=fTable[THashVal(H).Primary];
    while (Rec<>nil) do begin
        if Rec.fLine=S then begin
            THashVal(H).Secondary:=Rec.Secondary;
            Result:=true;
            Exit;
        end else Rec:=Rec.Next;
    end;
  end;

function THashTable.HashString(const S: string; out H: cardinal; out Rec: THashRec; Insert: boolean): boolean;
  begin
    H:=0;
    if InTable(S,H,Rec) then begin
        Result:=not Insert;// ~ if Insert then Result:=false else Result:=true;
    end else begin
        if Insert then begin
            if fTable[THashVal(H).Primary]<>nil
            then THashVal(H).Secondary:=fTable[THashVal(H).Primary].Secondary+1
            else THashVal(H).Secondary:=1;
            Rec:=fRecClass.Create(S,H);
            Rec.fNext:=fTable[THashVal(H).Primary];
            fTable[THashVal(H).Primary]:=Rec;
            Result:=true;
        end else Result:=false;
    end;
  end;

procedure THashTable.Remove(const H: cardinal);
  var Rec: THashRec;
      _Rec: THashRec;
  begin
    if THashVal(H).Primary>=Size then Exit;
    Rec:=fTable[THashVal(H).Primary];
    if Rec=nil then Exit;
    if Rec.Secondary=THashVal(H).Secondary then begin
        fTable[THashVal(H).Primary]:=Rec.Next;
        Rec.Free;
        Exit;
    end;
    while (Rec.Next<>nil) do begin
        if (Rec.Next.Secondary=THashVal(H).Secondary) then begin
            _Rec:=Rec.Next;
            Rec.fNext:=_Rec.Next;
            _Rec.Free;
            Exit;
        end else Rec:=Rec.Next;
    end;
  end;

procedure THashTable.Remove(const S: string);
  var H: cardinal;
      Rec: THashRec;
  begin
    HashString(S,H,Rec,false);
    Remove(H);
  end;

function THashTable.HashString(const S: string): cardinal;
  var Rec: THashRec;
  begin
    HashString(S,Result,Rec,true);
  end;

function THashTable.ExtractObject(H: cardinal): THashRec;
  begin
    if THashVal(H).Primary>=Size then begin
        Result:=nil; Exit;
    end;
    Result:=fTable[THashVal(H).Primary];
    while Result<>nil do begin
        if Result.Secondary=THashVal(H).Secondary then Exit
        else Result:=Result.Next;
    end;
  end;

function THashTable.AquireHash(const S: string; out H: cardinal;
                               out Rec: THashRec; Insert: boolean = true): boolean;
  begin
    Result:=HashString(S,H,Rec,Insert);
  end;

procedure THashTable.ReleaseHash(const S: string);
  var H: cardinal;
      Rec: THashRec;
  begin
    if HashString(S,H,Rec,false) then Remove(H);
  end;

procedure THashTable.ReleaseHash(H: cardinal);
  var Rec: THashRec;
  begin
    Rec:=ExtractObject(H);
    if Rec = nil then Exit;
    Remove(Rec.Hash)
  end;

procedure THashTable.ReleaseHash(Rec: THashRec);
  begin
    if Rec = nil then Exit;
    if Rec = ExtractObject(Rec.Hash) then Remove(Rec.Hash)
  end;

function THashTable.ExtractString(H: cardinal): string;
  var Rec: THashRec;
  begin
    Rec:=ExtractObject(H);
    if Rec <> nil then Result:=Rec.Line
  end;

procedure THashTable.Print(Lines: TStrings);
  var Stream: TStringStream;
  begin
    Stream:=TStringStream.Create('');
    Print(Stream);
    Lines.LoadFromStream(Stream);
    Stream.Free;
  end;

procedure THashTable.Print(Stream: TStream);
  var i: integer;
      Rec: THashRec;
      Str: string;
  begin
    for i:=0 to Size-1 do begin
        Rec:=fTable[i];
        while Rec <> nil do begin
            Str:=Rec.ToString;
            Stream.WriteBuffer(pointer(Str)^,Length(Str));
            Rec:=Rec.Next;
        end;
    end;
  end;

{ ### TThreadHashTable ####################################################### }

constructor TThreadHashTable.Create(ASize: integer = MIN_HASH_SIZE;
                                    ARecClass: THashRecClass = nil);
  begin
    fCritSec:=TCriticalSection.Create;
    try
      inherited;
    except
      fCritSec.Free;
      raise;
    end;
  end;

destructor TThreadHashTable.Destroy;
  var Sec: TCriticalSection;
  begin
    Sec:=fCritSec;
    try
      inherited;
    finally
      Sec.Free;
    end;
  end;

  { ### public ### }

function TThreadHashTable.AquireHash(const S: string; out H: cardinal;
                                     out Rec: THashRec; Insert: boolean = true): boolean;
  begin
    CritSec.Enter;
    try
      Result:=inherited AquireHash(S,H,Rec,Insert);
    finally
       CritSec.Leave;
    end;
  end;

procedure TThreadHashTable.Clear;
  begin
    CritSec.Enter;
    try
      inherited;
    finally
       CritSec.Leave;
    end;
  end;

procedure TThreadHashTable.LoadFromStrings(Strings: TStrings);
  begin
    CritSec.Enter;
    try
      inherited;
    finally
       CritSec.Leave;
    end;
  end;

procedure TThreadHashTable.ReleaseHash(const S: string);
  begin
    CritSec.Enter;
    try
      inherited;
    finally
       CritSec.Leave;
    end;
  end;

procedure TThreadHashTable.ReleaseHash(H: cardinal);
  begin
    CritSec.Enter;
    try
      inherited;
    finally
       CritSec.Leave;
    end;
  end;

procedure TThreadHashTable.ReleaseHash(Rec: THashRec);
  begin
    CritSec.Enter;
    try
      inherited;
    finally
       CritSec.Leave;
    end;
  end;

function TThreadHashTable.ExtractObject(H: cardinal): THashRec;
  begin
    CritSec.Enter;
    try
      Result:=inherited ExtractObject(H);
    finally
      CritSec.Leave;
    end;
  end;

procedure TThreadHashTable.Print(Stream: TStream);
  begin
    CritSec.Enter;
    try
      inherited;
    finally
       CritSec.Leave;
    end;
  end;

{ ### TLexParser ############################################################# }

constructor TLexParser.Create(ALexHashRecClass: TLexHashRecClass = nil);
  begin
    if ALexHashRecClass = nil then ALexHashRecClass:=TLexHashRec;
    if not ALexHashRecClass.InheritsFrom(TLexHashRec) then begin
        raise ELexParserLexHashRecClassError.CreateFmt(
                  'Specified class "%s" doesn''t inherits from "%s"',
                  [ALexHashRecClass.ClassName,TLexHashRec.ClassName]  );
    end;
    fLexHashRecClass:=ALexHashRecClass;
    fCharTrigger[ckEOL]:=trigEOL;
    fCharTrigger[ckSpace]:=trigSpace;
    fCharTrigger[ckLetter]:=trigLetter;
    fCharTrigger[ckNumber]:=trigNumber;
    fCharTrigger[ckSymbol]:=trigSymbol;
    fNullRec:=LexHashRecClass.Create('',NULL_HASH);
    fWords:=THashTable.Create(MIN_HASH_SIZE,LexHashRecClass);
  end;

destructor TLexParser.Destroy;
  begin
    fWords.Free;
    fNullRec.Free;
    inherited;
  end;

  { ### private ### }

procedure TLexParser.RecognizeLexem(Pos,Length: integer; Trigger: TTrigger);
  var H: cardinal;
      Rec: TLexHashRec;
      savRec: TLexHashRec;
      Len: integer;
      S: string;
  begin
    Rec:=nil;
    case Trigger of
      tgSpace: begin
          if fEmitSpace then fOnLexem(Self,Lexem(Pos,Length,lkSpace,nil));
      end;
      tgIdentifer: begin
          S:=Copy(PChar(fLine),Pos,Length);
          if Words.InTable(S,H,THashRec(Rec)) then begin
              case Rec.WordType of
                  wtKeyWord: fOnLexem(Self,Lexem(Pos,Length,lkKeyWord,Rec));
                  wtOperator: fOnLexem(Self,Lexem(Pos,Length,lkOperator,Rec));
                  wtOptWord: fOnLexem(Self,Lexem(Pos,Length,lkOptWord,NullRec));
              end;
          end else begin
              fOnLexem(Self,Lexem(Pos,Length,lkIdentifer,NullRec));
          end;
      end;
      tgIntNumber: begin
          fOnLexem(Self,Lexem(Pos,Length,lkIntNumber,NullRec));
      end;
      tgFloatNumber: begin
          fOnLexem(Self,Lexem(Pos,Length,lkFloatNumber,NullRec));
      end;
      tgSymbol: begin
          while Length<>0 do begin
              Len:=1;
              savRec:=nil;
              while (Len<=Length) and Words.InTable(Copy(PChar(fLine),Pos,Len),H,THashRec(Rec)) do begin
                  inc(Len);
                  savRec:=Rec;
              end;
              if Len=1 then begin
                  fOnLexem(Self,Lexem(Pos,Len,lkUnknown,NullRec)); //неизвестный символ оператора
              end else begin
                  dec(Len);
                  fOnLexem(Self,Lexem(Pos,Len,lkOperator,savRec));
              end;
              inc(Pos,Len);
              dec(Length,Len);
          end;
      end;
    end;//of case
  end;

procedure TLexParser.trigEOL;
  begin
    fCur:=fLen+1;
    if EmitEOL then fOnLexem(Self,Lexem(fCur,0,lkEOL,NullRec));
  end;

procedure TLexParser.trigSpace;
  var Pos: integer;
  begin
    Pos:=fCur;
    while CHARKIND[fLine[fCur]]=ckSpace do inc(fCur);
    RecognizeLexem(Pos,fCur-Pos,tgSpace);
  end;

procedure TLexParser.trigNumber;
  var Pos: integer;
      Trigger: TTrigger;
      WasDot: boolean;
      WasE: boolean;
  begin
    Trigger:=tgIntNumber;
    Pos:=fCur;
    WasDot:=false;
    WasE:=false;
    repeat                                        
        if CHARKIND[fLine[fCur]]=ckNumber then begin
            inc(fCur);
        end else if (fLine[fCur]='.')and(not WasDot) then begin
            WasDot:=true;
            Trigger:=tgFloatNumber;
            inc(fCur);
        end else if (Upcase(fLine[fCur])='E')and(not WasE) then begin
            WasE:=true;
            Trigger:=tgFloatNumber;
            inc(fCur);
            if ((fLine[fCur]='+')or(fLine[fCur]='-'))then inc(fCur);
        end else Break
    until false;
    RecognizeLexem(Pos,fCur-Pos,Trigger);
  end;

procedure TLexParser.trigLetter;
  var Pos: integer;
  begin
    Pos:=fCur;
    while CHARKIND[fLine[fCur]] in [ckLetter, ckNumber] do inc(fCur);
    RecognizeLexem(Pos,fCur-Pos,tgIdentifer);
  end;

procedure TLexParser.trigSymbol;
  var Pos: integer;
  begin
    Pos:=fCur;
    while CHARKIND[fLine[fCur]]=ckSymbol do inc(fCur);
    RecognizeLexem(Pos,fCur-Pos,tgSymbol);
  end;

procedure TLexParser.OwnOnLexem(Sender: TLexParser; const Lexem: TLexem);
  begin
    SetLength(fLexStorage,Length(fLexStorage)+1);
    fLexStorage[High(fLexStorage)]:=Lexem;
  end;

  { ### public ### }

procedure TLexParser.ProcessLine(const Line: PChar; Len: integer; OnLexem: TLexemEvent);
  begin
    fStopParsing:=false;
    fOnLexem:=OnLexem;
    fLine:=pointer(Line);
    fLen:=Len;
    fCur:=1;
    while (not fStopParsing)and(fCur<=fLen) do fCharTrigger[CHARKIND[fLine[fCur]]]
  end;

procedure TLexParser.ProcessLine(const Line: PChar; Len: integer; out LexStorage: TLexemStorage);
  begin
    fLexStorage:=nil;
    ProcessLine(Line,Len,OwnOnLexem);
    LexStorage:=fLexStorage;
    fLexStorage:=nil;
  end;

procedure TLexParser.StopParsing;
  begin
    fStopParsing:=true;
  end;

procedure TLexParser.AddWord(const Word: string; WordType: TWordType);
  var H: cardinal;
      Rec: TLexHashRec;
  begin
    Words.AquireHash(Word,H,THashRec(Rec),true);
    Rec.WordType:=WordType;
  end;

procedure TLexParser.ClearWords;
  begin
    Words.Clear;
  end;

{ ### TGuidedParser ########################################################## }

constructor TGuidedParser.Create;
  begin
    fParser:=TLexParser.Create;
  end;

destructor TGuidedParser.Destroy;
  begin
    fParser.Free;
    inherited;
  end;

  { ### private ### }

procedure TGuidedParser.SetLexPos(NewVal: integer);
  begin
    if NewVal<0 then fLexPos:=0
    else if NewVal>=fLexCount then SetLexPos(fLexCount-1)
    else fLexPos:=fLexCount;
  end;

  { ### public ### }

procedure TGuidedParser.Init(const Line: PChar; Len: integer);
  begin
    fParser.ProcessLine(Line,Len,fStorage);
    fLexCount:=Length(fStorage);
    fLexPos:=0;
  end;

function TGuidedParser.GetLexem(out Lexem: TLexem): boolean;
  begin
    if fLexPos>=fLexCount then Result:=false
    else begin
        Lexem:=fStorage[fLexPos];
        inc(fLexPos);
        Result:=true
    end;
  end;

{ ### TStackPage ############################################################# }

constructor TStackPage.Create(AHeadPage, AHeadOffset: integer);
  begin
    Grow(10);
    HeadPage:=AHeadPage;
    HeadOffset:=AHeadOffset;
  end;

destructor TStackPage.Destroy;
  begin
    FreeMem(fPage);
    inherited;
  end;

  { ### protected ### }

procedure TStackPage.Grow(PlaceCount: integer);
  begin
    inc(fCapacity,PlaceCount);
    ReallocMem(fPage,fCapacity*sizeof(tagElemType));
  end;

  { ### public ### }

procedure TStackPage.Clear;
  begin
    fCount:=0;
    if fPage <> nil then FillChar(fPage^,Capacity*sizeof(tagElemType),0);
  end;

procedure TStackPage.Add(Value: tagElemType);
  var Last: integer;
  begin
    Last:=fCount;
    inc(fCount);
    if fCount>fCapacity then Grow(10);
    fPage[Last]:=Value;
  end;

{ ### TPageAssocStack ######################################################## }

constructor TMagicStack.Create;
  begin
    Add;
    CurrentPage:=0;
  end;

destructor TMagicStack.Destroy;
  begin
    try
      DisposeLastPages(PageCount);
    finally
      FreeMem(fPages);
      inherited;
    end;
  end;

  { ### private ### }

procedure TMagicStack.SetPageCount(NewValue: integer);
  begin
    if NewValue <= 0 then NewValue:=1;
    if NewValue > PageCount then begin
        Add(NewValue-PageCount);
    end else if NewValue < PageCount then begin
        DisposeLastPages(PageCount-NewValue);
        if CurrentPage >= PageCount then CurrentPage:=PageCount-1;
    end;
  end;

procedure TMagicStack.SetCurrentPage(NewValue: integer);
  begin
    SelectStkHead(NewValue);
  end;

function TMagicStack.GetEmpty: boolean;
  var Value: tagElemType;
  begin
    Result:=not Top(Value);
  end;

  { ### protected ### }

procedure TMagicStack.Grow(PlaceCount: integer);
  begin
    inc(fCapacity,PlaceCount);
    ReallocMem(fPages,fCapacity*sizeof(TStackPage));
  end;

procedure TMagicStack.DisposeLastPages(Count: integer);
  var i: integer;
  begin
    if Count <= 0 then Exit;
    if Count > PageCount then Count:=PageCount;
    for i:=PageCount-1 downto PageCount-Count do fPages[i].Free;
    dec(fPageCount,Count);
  end;

  { ### public ### }

procedure TMagicStack.Clear;
  begin
    DisposeLastPages(PageCount);
    Add;
    CurrentPage:=0;
  end;

procedure TMagicStack.SelectStkHead(PageIndex: integer);
  begin
    if (PageIndex >= PageCount)or(PageIndex < 0) then
        raise EPagedStackError.Create('Page index out of bounds');
    fCurrentPage:=PageIndex;
    fStkHead:=fCurrentPage;
    fStkOffset:=fPages[fStkHead].Count-1;
  end;

procedure TMagicStack.Unite;
  begin
    if fCurrentPage > 0 then with fPages[fCurrentPage] do begin
        HeadPage:=fCurrentPage-1;
        HeadOffset:=fPages[HeadPage].Count-1;
    end;
  end;

procedure TMagicStack.Unite(Page1, Page2: integer);
  var tmp: integer;
  begin
    if Page1 = Page2 then Exit;
    if Page1 > Page2 then begin
        tmp:=Page1;
        Page1:=Page2;
        Page2:=tmp
    end;
    with fPages[Page2] do begin
        HeadPage:=Page1;
        HeadOffset:=fPages[HeadPage].Count-1;
    end;
  end;

procedure TMagicStack.ResetStkHead;
  begin
    SelectStkHead(CurrentPage);
  end;

procedure TMagicStack.CommitStkHead;
  begin
    if fStkHead = fCurrentPage then Exit;
    with fPages[fCurrentPage] do begin
        HeadPage:=fStkHead;
        HeadOffset:=fStkOffset;
    end;
  end;

procedure TMagicStack.Add(CountPages: integer = 1);
  var i: integer;
      First,Last: integer;
      Offset: integer;
      LstPg: integer;
  begin
    if CountPages <= 0 then Exit;
    LstPg:=PageCount-1;
    First:=fPageCount;
    inc(fPageCount,CountPages);
    Last:=fPageCount - 1;
    if PageCount > Capacity then Grow(CountPages+10);
    if LstPg >= 0 then Offset:=fPages[LstPg].Count-1
    else Offset:=-1;
    for i:=First to Last do begin
        fPages[i]:=TStackPage.Create(i-1,Offset);
        Offset:=fPages[i].Count-1;
    end;
  end;

procedure TMagicStack.Push(Value: tagElemType);
  begin
    CommitStkHead;
    fPages[fCurrentPage].Add(Value);
    fStkHead:=fCurrentPage;
    fStkOffset:=fPages[fCurrentPage].Count-1;
  end;

function TMagicStack.Pop(out Value: tagElemType): boolean;
  label GETVALUE;
  begin
GETVALUE:
    with fPages[fStkHead] do
      if fStkOffset >= 0 then begin
          Value:=fPage[fStkOffset];
          dec(fStkOffset);
          if fStkHead = fCurrentPage then
              dec(fPages[fCurrentPage].fCount);
          Result:=true
      end else begin
          if fStkHead > 0 then begin
              fStkHead:=HeadPage;
              fStkOffset:=HeadOffset;
              goto GETVALUE
          end else Result:=false
      end
  end;

function TMagicStack.Pop(out Value: tagElemType;
                       out StkPage, StkOffset: integer): boolean; 
  label GETVALUE;
  begin
GETVALUE:
    with fPages[fStkHead] do
      if fStkOffset >= 0 then begin
          Value:=fPage[fStkOffset];
          StkOffset:=fStkOffset;
          StkPage:=fStkHead;
          dec(fStkOffset);
          if fStkHead = fCurrentPage then
              dec(fPages[fCurrentPage].fCount);
          Result:=true
      end else begin
          if fStkHead > 0 then begin
              fStkHead:=HeadPage;
              fStkOffset:=HeadOffset;
              goto GETVALUE
          end else Result:=false
      end
  end;

function TMagicStack.Top(out Value: tagElemType): boolean;
  label GETVALUE;
  begin
GETVALUE:
    with fPages[fStkHead] do
      if fStkOffset >= 0 then begin
          Value:=fPage[fStkOffset];
          Result:=true
      end else begin
          if fStkHead > 0 then begin
              fStkHead:=HeadPage;
              fStkOffset:=HeadOffset;
              goto GETVALUE
          end else Result:=false
      end
  end;

function TMagicStack.Top(out Value: tagElemType;
                       out StkPage, StkOffset: integer): boolean;
  label GETVALUE;
  begin
GETVALUE:
    with fPages[fStkHead] do
      if fStkOffset >= 0 then begin
          Value:=fPage[fStkOffset];
          StkOffset:=fStkOffset;
          StkPage:=fStkHead;
          Result:=true
      end else begin
          if fStkHead > 0 then begin
              fStkHead:=HeadPage;
              fStkOffset:=HeadOffset;
              goto GETVALUE
          end else Result:=false
      end
  end;

{ ############################################################################ }

function CreateHashTable(ASize: integer = MIN_HASH_SIZE;
                         AHashRecClass: THashRecClass = nil): THashTable;
  begin
    Result:=THashTable.Create(ASize,AHashRecClass);
  end;

procedure FillCharKind;
  var i: Char;
  begin
    FillChar(CHARKIND,sizeof(CHARKIND)*sizeof(TCharKind),ckSpace);
    CHARKIND[#0]:=ckEOL;
    CHARKIND['@']:=ckSymbol;
    CHARKIND['#']:=ckSymbol;
    CHARKIND['№']:=ckSymbol;
    CHARKIND['$']:=ckSymbol;
    CHARKIND['%']:=ckSymbol;
    CHARKIND['^']:=ckSymbol;
    CHARKIND['+']:=ckSymbol;
    CHARKIND['-']:=ckSymbol;
    CHARKIND['*']:=ckSymbol;
    CHARKIND['/']:=ckSymbol;
    CHARKIND['&']:=ckSymbol;
    CHARKIND['|']:=ckSymbol;
    CHARKIND['=']:=ckSymbol;
    CHARKIND['<']:=ckSymbol;
    CHARKIND['>']:=ckSymbol;
    CHARKIND['~']:=ckSymbol;
    CHARKIND['`']:=ckSymbol; //обратная кавычка
    CHARKIND['"']:=ckSymbol;
    CHARKIND['!']:=ckSymbol;
    CHARKIND['.']:=ckSymbol;
    CHARKIND[',']:=ckSymbol;
    CHARKIND[#39]:=ckSymbol; //одиночная кавычка
    CHARKIND[';']:=ckSymbol;
    CHARKIND[':']:=ckSymbol;
    CHARKIND['(']:=ckSymbol;
    CHARKIND[')']:=ckSymbol;
    CHARKIND['[']:=ckSymbol;
    CHARKIND[']']:=ckSymbol;
    CHARKIND['}']:=ckSymbol;
    CHARKIND['{']:=ckSymbol;
    for i:='A' to 'Z' do CHARKIND[i]:=ckLetter;
    for i:='a' to 'z' do CHARKIND[i]:=ckLetter;
    for i:='А' to 'Я' do CHARKIND[i]:=ckLetter;
    for i:='а' to 'я' do CHARKIND[i]:=ckLetter;
    CHARKIND['ё']:=ckLetter;
    CHARKIND['Ё']:=ckLetter;
    CHARKIND['й']:=ckLetter;
    CHARKIND['Й']:=ckLetter;
    CHARKIND['_']:=ckLetter;
    for i:='0' to '9' do CHARKIND[i]:=ckNumber;
  end;

function Lexem(Pos,Length: integer; Kind: TLexemKind; Rec: TLexHashRec): TLexem;
  begin
    Result.Pos:=Pos;
    Result.Length:=Length;
    Result.Kind:=Kind;
    Result.Rec:=Rec;
  end;

initialization
  FillCharKind;

end.