zscanner.pas

控件名称：WINZEOS.ZIP 2002年08月03日 作者：CapellaDevelopment Zeos系列构件套件包含一组可直接存取Linux知名的免费数据库MySQL、Postgre

{********************************************************}
{                                                        }
{                 Zeos Database Objects                  }
{                 Lexical Scanner Class                  }
{                                                        }
{       Copyright (c) 1999-2001 Sergey Seroukhov         }
{    Copyright (c) 1999-2001 Zeos Development Group      }
{                                                        }
{********************************************************}

unit ZScanner;

interface

uses SysUtils;

const
  { Token types definitions }
  tokUnknown   = $0000;
  tokComment   = $0001;

  tokKeyword   = $0002;
  tokType      = $0004;
  tokIdent     = $0008;
  tokAlpha     = $000E;

  tokOperator  = $0010;
  tokBrace     = $0020;
  tokSeparator = $0040;
  tokEol       = $0080;
  tokLF        = $00E0;
  tokDelim     = $00F0;

  tokInt       = $0100;
  tokFloat     = $0200;
  tokString    = $0400;
  tokBool      = $0800;
  tokConst     = $0F00;

  tokEof       = $8000;

type
  { Abstract scanner class definition }
  TZScanner = class
  protected
    FBuffer: string;
    FBufferPos, FBufferLine, FBufferLen: Integer;
    FTokenType, FNextTokenType: Integer;
    FToken, FNextToken: string;
    FLineNo, FNextLineNo: Integer;
    FPosition, FNextPosition: Integer;
    FShowComment: Boolean;
    FShowString: Boolean;
    FShowEol: Boolean;
    FShowKeyword: Boolean;
    FShowType: Boolean;
    
    procedure SetBuffer(Value: string);
    function GetNextLineNo: Integer;
    function GetNextToken: string;
    function GetNextPosition: Integer;
    function GetNextTokenType: Integer;

    function LowRunLex(var CurrPos, CurrLineNo: Integer;
      var CurrToken: string): Integer; virtual;
    function RunLex(var CurrPos, CurrLineNo: Integer;
      var CurrToken: string): Integer; virtual;

    procedure ExtractToken;
    procedure ExtractNextToken;

    function InnerStartLex(var CurrPos, CurrLineNo: Integer;
      var CurrToken: string): Integer;
    function InnerProcLineComment(var CurrPos, CurrLineNo: Integer;
      var CurrToken: string): Integer;
    function InnerProcCComment(var CurrPos, CurrLineNo: Integer;
      var CurrToken: string): Integer;
    function InnerProcIdent(var CurrPos, CurrLineNo: Integer;
      var CurrToken: string): Integer;
    function InnerProcCString(var CurrPos, CurrLineNo: Integer;
      var CurrToken: string): Integer;
    function InnerProcPasString(var CurrPos, CurrLineNo: Integer;
      var CurrToken: string): Integer;
  public
    constructor Create; virtual;
    destructor Destroy; override;

    procedure Restart;

    function WrapString(Value: string): string; virtual;
    function UnwrapString(Value: string): string; virtual;

    class function IsAlpha(Value: Char): Boolean; virtual;
    class function IsDigit(Value: Char): Boolean; virtual;
    class function IsDelim(Value: Char): Boolean; virtual;
    class function IsWhite(Value: Char): Boolean; virtual;
    class function IsEol(Value: Char): Boolean; virtual;
    class function IsQuote(Value: Char): Boolean; virtual;

    function Lex: Integer;
    function GotoNextToken: Integer;

    property ShowComment: Boolean read FShowComment write FShowComment;
    property ShowEol: Boolean read FShowEol write FShowEol;
    property ShowString: Boolean read FShowString write FShowString;
    property ShowKeyword: Boolean read FShowKeyword write FShowKeyword;
    property ShowType: Boolean read FShowType write FShowType;

    property Buffer: string read FBuffer write SetBuffer;
    property BufferPos: Integer read FBufferPos;

    property Position: Integer read FPosition;
    property LineNo: Integer read FLineNo;
    property Token: string read FToken;
    property TokenType: Integer read FTokenType;

    property NextPosition: Integer read GetNextPosition;
    property NextLineNo: Integer read GetNextLineNo;
    property NextToken: string read GetNextToken;
    property NextTokenType: Integer read GetNextTokenType;
  end;

  { Pascal-like scanner class definition }
  TZPasScanner = class (TZScanner)
  protected
    function LowRunLex(var CurrPos, CurrLineNo: Integer;
      var CurrToken: string): Integer; override;
  public
    function WrapString(Value: string): string; override;
    function UnwrapString(Value: string): string; override;
  end;

  { C-like scanner class definition }
  TZCScanner = class (TZScanner)
  protected
    function LowRunLex(var CurrPos, CurrLineNo: Integer;
      var CurrToken: string): Integer; override;
  public
    function WrapString(Value: string): string; override;
    function UnwrapString(Value: string): string; override;
  end;

implementation

{ TZScanner }

{ Class constructor }
constructor TZScanner.Create;
begin
  FBufferPos := 1;
  FBufferLine := 1;
  FShowKeyword := True;
  FShowType := True;
  FShowString := True;
end;

{ Class destructor }
destructor TZScanner.Destroy;
begin
  inherited Destroy;
end;

{ Set new string buffer }
procedure TZScanner.SetBuffer(Value: string);
begin
  FBuffer := Value;
  FBufferLen := Length(FBuffer);
  FBufferPos := 1;
  FBufferLine := 1;
  FTokenType := tokEof;
  FNextTokenType := tokUnknown;
  FToken := '';
  FNextToken := '';
  FLineNo := 0;
  FNextLineNo := 0;
  FPosition := 0;
  FNextPosition := 0;
end;

{ Get next line no }
function TZScanner.GetNextLineNo: Integer;
begin
  ExtractNextToken;
  Result := FNextLineNo;
end;

{ Get next position }
function TZScanner.GetNextPosition: Integer;
begin
  ExtractNextToken;
  Result := FNextPosition;
end;

{ Get next token value }
function TZScanner.GetNextToken: string;
begin
  ExtractNextToken;
  Result := FNextToken;
end;

{ Get next token type }
function TZScanner.GetNextTokenType: Integer;
begin
  ExtractNextToken;
  Result := FNextTokenType;
end;

{ Convert string value into string }
function TZScanner.WrapString(Value: string): string;
begin
  Result := '"' + Value + '"';
end;

{ Unconvert string into string value }
function TZScanner.UnwrapString(Value: string): string;
var
  Quote: Char;
begin
  Result := Value;
  if Result = '' then Exit;
  { Delete start and end quotes }
  Quote := Result[1];
  if Quote in ['"', ''''] then Delete(Result, 1, 1)
  else Exit;
  if (Result <> '') and (Result[Length(Result)] = Quote) then
    Delete(Result, Length(Result), 1);
end;

{ Extract next token }
procedure TZScanner.ExtractNextToken;
begin
  if (FNextToken = '') and (FNextTokenType = tokUnknown) then
    FNextTokenType := RunLex(FNextPosition, FNextLineNo, FNextToken);
end;

{ Extract current token }
procedure TZScanner.ExtractToken;
begin
  if (FNextToken <> '') and (FNextTokenType <> tokUnknown) then
  begin
    { Move next token to current token }
    FTokenType := FNextTokenType;
    FLineNo := FNextLineNo;
    FPosition := FNextPosition;
    FToken := FNextToken;
    { Clear next token }
    FNextTokenType := tokUnknown;
    FNextLineNo := 0;
    FNextPosition := 0;
    FNextToken := '';
  end else
    FTokenType := RunLex(FPosition, FLineNo, FToken);
end;

{ Get next token alias }
function TZScanner.GotoNextToken: Integer;
begin
  Result := Lex;
end;

{ Get next token }
function TZScanner.Lex: Integer;
begin
  ExtractToken;
  Result := TokenType;
end;

{ Extract token }
function TZScanner.RunLex(var CurrPos, CurrLineNo: Integer;
  var CurrToken: string): Integer;
begin
  { Get current token }
  repeat
    Result := LowRunLex(CurrPos, CurrLineNo, CurrToken);
    if (Result in [tokEol, tokLF]) and FShowEol then
      Break;
    if (Result = tokComment) and FShowComment then
      Break;
  until not (Result in [tokEol, tokLF, tokComment]);
  { Convert string if needed }
  if (Result = tokString) and not ShowString then
    CurrToken := UnwrapString(CurrToken);
end;

{******************** Lexical procedures *********************}

{ Start lexical scaning }
function TZScanner.InnerStartLex(var CurrPos, CurrLineNo: Integer;
  var CurrToken: string): Integer;
begin
  { Initialize values }
  Result := tokEof;
  CurrLineNo := FBufferLine;
  CurrPos := FBufferPos;
  CurrToken := '';
  { Check position }
  if FBufferPos > FBufferLen then Exit;
  { Skip whitespaces }
  while FBuffer[FBufferPos] in [' ',#9] do
  begin
    Inc(FBufferPos);
    if FBufferPos > FBufferLen then
    begin
      CurrPos := FBufferPos;
      Exit;
    end;
  end;
  CurrPos := FBufferPos;
  CurrToken := FBuffer[FBufferPos];
  Inc(FBufferPos);

  { Check for LF }
  if CurrToken[1] = #10 then
  begin
    Result := tokLF;
    Exit;
  end;

  { Check for EOL }
  if CurrToken[1] = #13 then
  begin
    Result := tokEol;
    Inc(FBufferLine);
    Exit;
  end;
  Result := tokUnknown;
end;

{ Process identificator }
function TZScanner.InnerProcIdent(var CurrPos, CurrLineNo: Integer;
  var CurrToken: string): Integer;
var
  Temp: Char;
begin
  Result := tokUnknown;
  if CurrToken[1] in ['0'..'9','.','a'..'z','A'..'Z','_','$'] then
  begin
    Temp := CurrToken[1];
    if Temp = '.' then Result := tokFloat
    else if Temp in ['0'..'9'] then Result := tokInt
    else Result := tokIdent;

    while FBufferPos <= FBufferLen do
    begin
      Temp := FBuffer[FBufferPos];
      if not (Temp in ['0'..'9','.','a'..'z','A'..'Z','_','$']) then
        Break;
      if (Result = tokInt) and (Temp = '.') then
        Result := tokFloat;
      CurrToken := CurrToken + Temp;
      Inc(FBufferPos);
    end;
  end;
end;

{ Process C-like escape string }
function TZScanner.InnerProcCString(var CurrPos, CurrLineNo: Integer;
  var CurrToken: string): Integer;
var
  Temp, Quote: Char;
begin
  Result := tokUnknown;
  if IsQuote(CurrToken[1]) then
  begin
    Result := tokString;
    Quote := CurrToken[1];
    while FBufferPos <= FBufferLen do
    begin
      Temp := FBuffer[FBufferPos];
      CurrToken := CurrToken + Temp;
      Inc(FBufferPos);
      if (Temp = '\') and ((FBufferPos <= FBufferLen)
        and (FBuffer[FBufferPos] = Quote)) then
      begin
        CurrToken := CurrToken + Quote;
        Inc(FBufferPos);
      end
      else if Temp = Quote then
        Break;
    end;
  end
end;

{ Process Pascal-like string }
function TZScanner.InnerProcPasString(var CurrPos, CurrLineNo: Integer;
  var CurrToken: string): Integer;
var
  Temp, Quote: Char;
begin
  Result := tokUnknown;
  if IsQuote(CurrToken[1]) then
  begin
    Result := tokString;
    Quote := CurrToken[1];
    while FBufferPos <= FBufferLen do
    begin
      Temp := FBuffer[FBufferPos];
      CurrToken := CurrToken + Temp;
      Inc(FBufferPos);
      if (Temp = Quote) and ((FBufferPos <= FBufferLen)
        and (FBuffer[FBufferPos] = Quote)) then
      begin
        CurrToken := CurrToken + Quote;
        Inc(FBufferPos);
      end
      else if Temp = Quote then
        Break;
    end;
  end
end;

{ Process C-like multi-line comment }
function TZScanner.InnerProcCComment(var CurrPos, CurrLineNo: Integer;
  var CurrToken: string): Integer;
var
  Temp, Temp1: Char;
begin
  Result := tokUnknown;
  if (CurrToken[1] = '/') and (FBufferPos <= FBufferLen)
    and (FBuffer[FBufferPos] = '*') then
  begin
    Result := tokComment;
    Temp1 := #0;
    while FBufferPos <= FBufferLen do
    begin
      Temp := FBuffer[FBufferPos];
      CurrToken := CurrToken + Temp;
      Inc(FBufferPos);
      if (Temp = '/') and (Temp1 = '*') then
        Break;
      if Temp = #13 then
        Inc(FBufferLine);
      Temp1 := Temp;
    end;
  end
end;

{ Process single-line comment }
function TZScanner.InnerProcLineComment(var CurrPos, CurrLineNo: Integer;
  var CurrToken: string): Integer;
var
  Temp: Char;
begin
  Result := tokComment;
  while FBufferPos <= FBufferLen do
  begin
    Temp := FBuffer[FBufferPos];
    CurrToken := CurrToken + Temp;
    Inc(FBufferPos);
    if Temp = #13 then
    begin
      Inc(FBufferLine);
      Break;
    end;
  end;
end;

{ Get lowlevel token }
function TZScanner.LowRunLex(var CurrPos, CurrLineNo: Integer;
  var CurrToken: string): Integer;
var