dws2tokenizer.pas

script language

{**********************************************************************}
{                                                                      }
{    "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 DelphiWebScriptII source code, released      }
{    January 1, 2001                                                   }
{                                                                      }
{    The Initial Developer of the Original Code is Matthias            }
{    Ackermann. Portions created by Matthias Ackermann are             }
{    Copyright (C) 2000 Matthias Ackermann, Switzerland. All           }
{    Rights Reserved.                                                  }
{                                                                      }
{    Contributor(s): Martin Waldenburg                                 }
{                                                                      }
{**********************************************************************}

{$I dws2.inc}

unit dws2Tokenizer;

interface

uses
  SysUtils, Classes, dws2Errors;

type
  TTokenType =
    (ttNone, ttStrVal, ttIntVal, ttFloatVal, ttNAME, ttSWITCH,
    ttVAR, ttCONST, ttTYPE, ttRECORD, ttARRAY, ttDOT, ttDOTDOT, ttOF,
    ttTRY, ttEXCEPT, ttRAISE, ttFINALLY, ttON, ttREAD, ttWRITE, ttPROPERTY,
    ttPROCEDURE, ttFUNCTION, ttCONSTRUCTOR, ttDESTRUCTOR, ttCLASS, ttNIL, ttIS,
    ttAS, ttINDEX, ttOBJECT,
    ttVIRTUAL, ttOVERRIDE, ttREINTRODUCE, ttINHERITED, ttABSTRACT,
    ttEXTERNAL, ttFORWARD, ttIN,
    ttBEGIN, ttEND, ttBREAK, ttCONTINUE, ttEXIT,
    ttIF, ttTHEN, ttELSE, ttWHILE, ttREPEAT, ttUNTIL, ttFOR, ttTO, ttDOWNTO, ttDO,
    ttCASE,
    ttTRUE, ttFALSE, ttAND, ttOR, ttXOR, ttDIV, ttMOD, ttNOT, ttPLUS, ttMINUS,
    ttTIMES, ttDIVIDE,
    ttEQ, ttNOTEQ, ttGTR, ttGTREQ, ttLESS, ttLESSEQ, ttSEMI, ttCOMMA, ttCOLON,
    ttASSIGN,
    ttBLEFT, ttBRIGHT, ttALEFT, ttARIGHT, ttCRIGHT,
    ttDEFAULT, ttUSES,

    // Tokens for compatibility to Delphi
    ttPRIVATE, ttPROTECTED, ttPUBLIC, ttPUBLISHED,
    ttREGISTER, ttPASCAL, ttCDECL, ttSTDCALL, ttFASTCALL);

  TTokenTypes = set of TTokenType;

  TToken = class
    FTyp: TTokenType;
    FPos: TScriptPos;
    FString: string;
    FFloat: Double;
    FInteger: Integer;
    constructor Create;
  end;

  TCharsType = set of char;
  TTransition = class;

  TState = class
    FTransitions: TList;
    FElseTransition: TTransition;
    constructor Create;
    destructor Destroy; override;
    function FindTransition(c: char): TTransition;
    procedure AddTransition(o: TTransition);
    procedure SetElse(o: TTransition);
  end;

  TConvertAction = (caNone, caClear, caName, caHex, caInteger, caFloat, caChar,
    caCharHex, caString, caSwitch, caDotDot);
  TTransitionOptions = set of (toStart, toFinal);

  TTransition = class
    Chars: set of char;
    NextState: TState;
    Start: Boolean; // Marks the begin of a Token
    Final: Boolean; // Marks the end of a Token
    Action: TConvertAction;
    constructor Create(chrs: TCharsType; nstate: TState; opts: TTransitionOptions;
      actn: TConvertAction);
  end;

  TElseTransition = class(TTransition)
    constructor Create(actn: TConvertAction);
  end;

  TErrorTransition = class(TTransition)
    ErrorMessage: string;
    constructor Create(msg: string);
  end;

  TCheckTransition = class(TTransition);
  TSeekTransition = class(TCheckTransition); // Transition, next char
  TConsumeTransition = class(TSeekTransition);
  // Transition, consume char, next char

  TSwitchHandler = function(SwitchName: string): Boolean of object;

  TTokenizer = class
  private
    FDefaultPos: TScriptPos;
    FHotPos: TScriptPos;
    FMsgs: TMsgs;
    FNextToken: TToken;
    FPos: TScriptPos;
    FStartState: TState;
    FSwitchHandler: TSwitchHandler;
    FText: string;
    FToken: TToken;
    function ConsumeToken: TToken; virtual;
    function NameToType(const name: string): TTokenType; virtual;
    procedure ReadToken;
    procedure ReadNextToken;
  public
    constructor Create(const Text, SourceFile: string; Msgs: TMsgs); virtual;
    destructor Destroy; override;
    function GetToken: TToken;
    function HasTokens: Boolean;
    procedure KillToken;
    function NextTest(t: TTokenType): Boolean;
    function Test(t: TTokenType): Boolean;
    function TestDelete(t: TTokenType): Boolean;
    function NextTestName: Boolean;
    function TestName: Boolean;
    function TestDeleteName: Boolean;
    property DefaultPos: TScriptPos read FDefaultPos;
    property HotPos: TScriptPos read FHotPos;
    property CurrentPos: TScriptPos read FPos;
    property SwitchHandler: TSwitchHandler read FSwitchHandler write
      FSwitchHandler;
  end;

implementation

uses
  dws2Strings;

const ReservedNames : TTokenTypes = [
  ttStrVal, ttSWITCH, ttSEMI, ttDIVIDE, ttTIMES, ttPLUS, ttMINUS, ttSEMI,
  ttBLEFT, ttBRIGHT, ttALEFT, ttARIGHT, ttEQ, ttLESS, ttLESSEQ, ttNOTEQ, ttGTR,
  ttGTREQ, ttCOLON, ttASSIGN, ttCOMMA, ttCRIGHT, ttDOT ];

{ TToken }

constructor TToken.Create;
begin
  FTyp := ttNone;
  FPos := NullPos;
end;

{ TState }

constructor TState.Create;
begin
  FTransitions := TList.Create;
end;

destructor TState.Destroy;
var
  x: Integer;
begin
  for x := 0 to FTransitions.Count - 1 do
    TTransition(FTransitions[x]).Free;
  FTransitions.Free;
  FElseTransition.Free;
  inherited Destroy;
end;

function TState.FindTransition(c: char): TTransition;
var
  x: Integer;
begin
  Result := nil;
  for x := 0 to FTransitions.Count - 1 do
    if c in TTransition(FTransitions[x]).Chars then
    begin
      Result := FTransitions[x];
      exit;
    end;

  if not Assigned(Result) then
    Result := FElseTransition;
end;

procedure TState.AddTransition(o: TTransition);
begin
  FTransitions.Add(o);
end;

procedure TState.SetElse(o: TTransition);
begin
  FElseTransition := o;
end;

{ TTransition }

constructor TTransition.Create;
begin
  Chars := chrs;
  NextState := nstate;
  Start := toStart in opts;
  Final := toFinal in opts;
  Action := actn;
end;

{ TElseTransition }

constructor TElseTransition.Create(actn: TConvertAction);
begin
  Chars := [];
  NextState := nil;
  Start := false;
  Action := actn;
end;

{ TErrorTransition }

constructor TErrorTransition.Create(msg: string);
begin
  ErrorMessage := msg;
end;

var
  sStart, sSpace, sComment, sCommentF, sSlashComment, sSlashComment0: TState;
  sSwitch, sSwitchNameF, sChar0, sCharF, sCharHex, sCharHexF: TState;
  sNameF: TState;
  sIntF, sIntPoint, sIntPointF, sIntExp, sIntExp0, sIntExpF, sHex, sHexF: TState;
  sString0, sStringF, sAssign0: TState;
  sGreaterF, sSmallerF, sDotDot: TState;

  { TTokenizer }

constructor TTokenizer.Create;
begin
{$IFDEF LINUX}
  FText := Text + #10#0;
{$ELSE}
  FText := Text + #13#10#0;
{$ENDIF}
  FToken := nil;
  FMsgs := Msgs;
  FNextToken := nil;
  FDefaultPos := NullPos;
  FDefaultPos.SourceFile := FMsgs.RegisterSourceFile(SourceFile, Text);
  FHotPos := FDefaultPos;
  FPos := FDefaultPos;
  FPos.Pos := 1;
  FPos.Line := 1;
  FPos.Col := 1;
  FStartState := sStart;
end;

destructor TTokenizer.Destroy;
begin
  FToken.Free;
  FNextToken.Free;
  inherited;
end;

procedure TTokenizer.ReadToken;
begin
  KillToken;

  if Assigned(FNextToken) then
  begin
    FToken := FNextToken;
    FNextToken := nil;
  end
  else
    FToken := ConsumeToken;
end;

procedure TTokenizer.ReadNextToken;
begin
  if not Assigned(FNextToken) then
    FNextToken := ConsumeToken;
end;

function TTokenizer.GetToken: TToken;
begin
  Result := FToken;
end;

function TTokenizer.Test(t: TTokenType): Boolean;
begin
  Result := false;
  if not Assigned(FToken) then
    ReadToken;
  if Assigned(FToken) then
  begin
    Result := (FToken.FTyp = t);
    FHotPos := FToken.FPos;
  end;
end;

function TTokenizer.TestDelete(t: TTokenType): Boolean;
begin
  Result := Test(t);
  if Result then
    KillToken;
end;

function TTokenizer.NextTest(t: TTokenType): Boolean;
begin
  Result := false;
  ReadNextToken;
  if Assigned(FNextToken) then
    Result := (FNextToken.FTyp = t);
end;

function TTokenizer.TestName: Boolean;
begin
  Result := false;
  if not Assigned(FToken) then
    ReadToken;
  if Assigned(FToken) then
  begin
    Result := (FToken.FString <> '') and not (FToken.FTyp in ReservedNames);
    FHotPos := FToken.FPos;
  end;
end;

function TTokenizer.TestDeleteName: Boolean;
begin
  Result := TestName;
  if Result then
    KillToken;
end;

function TTokenizer.NextTestName: Boolean;
begin
  Result := false;
  ReadNextToken;
  if Assigned(FNextToken) then
    Result := (FNextToken.FString <> '') and not (FToken.FTyp in ReservedNames);
end;

function TTokenizer.HasTokens: Boolean;
begin
  if not Assigned(FToken) then
    ReadToken;
  Result := FToken <> nil;
end;

function TTokenizer.ConsumeToken: TToken;
var
  state: TState;
  trns: TTransition;
  s: string;
  ch, oldsep: char;
begin
  Result := TToken.Create;
  state := FStartState;
  s := '';

  try
    // Look for the next token in FText
    while (FPos.Pos <= Length(FText)) and Assigned(state) do
    begin

      // Next character
      ch := FText[FPos.Pos];

      // Find next state
      trns := state.FindTransition(ch);

      // Handle Errors
      if trns is TErrorTransition then
        FMsgs.AddCompilerStop(FPos,
          Format('%s ("%s")', [TErrorTransition(trns).ErrorMessage, ch]));

      // A new token begins
      if trns.Start and (Result.FPos.Pos = -1) then
        Result.FPos := FPos;

      // Add actual character to s
      if trns is TConsumeTransition then
        s := s + ch;

      // Proceed to the next character
      if trns is TSeekTransition then
      begin
        Inc(FPos.Pos);
        Inc(FPos.Col);
        if ch = #10 then
        begin
          Inc(FPos.Line);
          FPos.Col := 1;
        end;
      end;

      // The characters in 's' have to be converted
      if trns.Action <> caNone then
      begin
        case trns.Action of
          caClear:
            begin
              s := '';
              Result.FPos := DefaultPos;
            end;

          // Convert name to token
          caName:
            begin
              Result.FTyp := NameToType(s);
              Result.FString := s;
            end;

          // converts ASCII code to character
          caChar:
            begin
              try
                if (StrToInt(s) > $FF) or (StrToInt(s) < 0) then
                  raise Exception.Create('');
                Result.FString := Result.FString + Chr(Byte(StrToInt(s)));
                Result.FTyp := ttStrVal;
              except
                FMsgs.AddCompilerStop(FPos, Format(TOK_InvalidCharConstant, [s]));
              end;
            end;

          // Converts hex constant to character
          caCharHex:
            begin
              try
                if (StrToInt(s) > $FF) or (StrToInt(s) < 0) then
                  raise Exception.Create('');
                Result.FString := Result.FString + Chr(Byte(StrToInt(s)));
                Result.FTyp := ttStrVal;
              except
                FMsgs.AddCompilerStop(FPos, Format(TOK_InvalidCharConstant, [s]));
              end;
            end;

          // Concatenates the parts of a string constant
          caString:
            begin
              Result.FString := Result.FString + s;
              Result.FTyp := ttStrVal;
            end;

          // Converts hexadecimal number to integer
          caHex:
            begin
              try
                Result.FInteger := StrToInt(s);
                Result.FTyp := ttIntVal;
              except
                on e: Exception do
                  FMsgs.AddCompilerStop(FPos, Format(TOK_InvalidHexConstant, [s]));
              end;
            end;

          // Converts integer constants
          caInteger:
            begin
              try
                if s[Length(s)] = '.' then
                  Delete(s, Length(s), 1);
                Result.FInteger := StrToInt(s);
                Result.FTyp := ttIntVal;
              except
                on e: Exception do
                  FMsgs.AddCompilerStop(FPos, Format(TOK_InvalidIntegerConstant,
                    [s]));
              end;