» Code template file for the Delphi Compiler Generator (DCG), special version for
» a syntax highlighter.
» target language is Delphi
» Note: - the character "" is considered as DCG comment, all text follwing this char
»         will not appear in the target,
»       - identifiers enclosed in "" and "" are considered as macros which will be
»         replaced by corresponding strings defined in the global definition section
»         of the according lexer template (*.l file)
unit UCESQLHighlighter;

// This file is machine-generated. Do not modify it manually.

interface

uses
  Classes, Graphics, UCEHighlighter;

const
  CR = #13;
  LF = #10;

// User defined start states and tokens.
%%

type
  TUCESQLHighlighter = class(TUCEHighlighter)
  private
    FCurrentToken: Integer;            // type of current token
    FInput: PChar;                     // input string to be tokenized
    FCurrentPos: Cardinal;             // current lexer position in FInput
    FTokenPos: Cardinal;               // current token position in FInput
    FLookahead: Char;                  // next char after current position
    FCurrentState,
    FStartState,
    FLineState: Cardinal;              // lexer states
    FLastChar: Char;                   // last matched char (#0 if no match)
    FPositions: array of Cardinal;     // for each rule the last marked position, zeroed when
                                       // rule has already been considered (allocated once)
    FMatchStack: array of Cardinal;    // stack containing matched rules (growing dynamically)
    FMatchCount: Integer;              // contains current number of matches
    FRejected: Boolean;                // current match rejected?
    FDoStop: Boolean;                  // token or eof found?
    FEOL: Boolean;

    FSystemVariableAttributes,
    FUserVariableAttributes,
    FCommentWithCOmmandAttributes,
    FEmbeddedCommandAttributes,
    FStringAttributes,
    FNumberAttributes,
    FKeyAttributes,
    FSymbolAttributes,
    FCommentAttributes,
    FIdentifierAttributes,
    FSpaceAttributes: THighlightAttributes;
    procedure RuleToToken(Rule: Integer);
    function IsKeyword: Boolean;
    function GetNextChar: Char;
    function MatchRule(var Rule: Integer): Boolean;
    function DoDefault: Boolean;
    function GetCurrentChar: Char;
    procedure SetAttribute(const Index: Integer; const Value: THighlightAttributes);
    procedure HighlightChange(Sender: TObject);
  protected
    procedure Reset; virtual;
    procedure SetMatch(I: Integer);
    procedure SetState(Value: Cardinal); virtual;
    procedure SetToken(Token: Integer);
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;

    function EOL: Boolean; override;
    function GetToken: string; override;
    function GetTokenInfo: TTokenData; override;
    procedure Next; override;
    procedure Reject;
    function GetAttribute(Index: Integer): THighlightAttributes; override;
    function GetAttributeCount: Integer; override;
    function GetIdentChars: TIdentChars; override;
    function GetLanguageName: string; override;
    function GetRange: Integer; override;
    function HasMoreTokens: Boolean; override;
    procedure ResetRange; override;
    procedure SetRange(Value: Integer); override;
    procedure SetLine(const NewValue: string); override;

    property CurrentChar: Char read GetCurrentChar;
    property NextChar: Char read GetNextChar;
    property Lookahead: Char read FLookahead;
    property State: Cardinal read FCurrentState write SetState; // read to get current lexer state
                                                                // write to set start state for next run
    property TokenPosition: Cardinal read FTokenPos;
  published
    property CommentAttributes: THighlightAttributes index 1 read FCommentAttributes write SetAttribute;
    property CommentWithCommandAttributes: THighlightAttributes index 8 read FCommentWithCommandAttributes write SetAttribute;
    property EmbeddedCommandAttributes: THighlightAttributes index 7 read FEmbeddedCommandAttributes write SetAttribute;
    property IdentifierAttributes: THighlightAttributes index 2 read FIdentifierAttributes write SetAttribute;
    property KeyAttributes: THighlightAttributes index 3 read FKeyAttributes write SetAttribute;
    property NumberAttributes: THighlightAttributes index 4 read FNumberAttributes write SetAttribute;
    property SpaceAttributes: THighlightAttributes index 5 read FSpaceAttributes write SetAttribute;
    property StringAttributes: THighlightAttributes index 6 read FStringAttributes write SetAttribute;
    property SymbolAttributes: THighlightAttributes index 7 read FSymbolAttributes write SetAttribute;
    property SystemVariableAttributes: THighlightAttributes index 9 read FSystemVariableAttributes write SetAttribute;
    property UserVariableAttributes: THighlightAttributes index 10 read FuserVariableAttributes write SetAttribute;
  end;

//----------------------------------------------------------------------------------------------------------------------

implementation

uses
  SysUtils;

// DFA table
%%

//----------------------------------------------------------------------------------------------------------------------

constructor TUCESQLHighlighter.Create(AOwner: TComponent);

begin
  inherited;
  // allocate positions array (length is highest possible mark position)
  SetLength(FPositions, MarksHigh[StateCount - 1] + 1);

  FCommentAttributes := THighlightAttributes.Create('comment');
  FCommentAttributes.Style := [fsItalic];
  FIdentifierAttributes := THighlightAttributes.Create('identifier');
  FKeyAttributes := THighlightAttributes.Create('reserved word');
  FKeyAttributes.Style := [fsBold];
  FNumberAttributes := THighlightAttributes.Create('number');
  FSpaceAttributes := THighlightAttributes.Create('space');
  FStringAttributes := THighlightAttributes.Create('String');
  FSymbolAttributes := THighlightAttributes.Create('symbol');
  FCommentWithCommandAttributes := THighlightAttributes.Create('comment with command');
  FEmbeddedCommandAttributes := THighlightAttributes.Create('embedded command');
  FSystemVariableAttributes := THighlightAttributes.Create('system variable');
  FUserVariableAttributes := THighlightAttributes.Create('user variable');

  FCommentAttributes.Onchange := HighlightChange;
  FIdentifierAttributes.Onchange := HighlightChange;
  FKeyAttributes.Onchange := HighlightChange;
  FNumberAttributes.Onchange := HighlightChange;
  FSpaceAttributes.Onchange := HighlightChange;
  FStringAttributes.Onchange := HighlightChange;
  FSymbolAttributes.Onchange := HighlightChange;
  FCommentWithCommandAttributes.Onchange := HighlightChange;
  FEmbeddedCommandAttributes.Onchange := HighlightChange;
  FSystemVariableAttributes.Onchange := HighlightChange;
  FUserVariableAttributes.Onchange := HighlightChange;

  DefaultFilter := 'SQL script files (*.sql)|*.sql';
end;

//----------------------------------------------------------------------------------------------------------------------

destructor TUCESQLHighlighter.Destroy;

begin
  FPositions := nil;
  FMatchStack := nil;
  FCommentAttributes.Free;
  FIdentifierAttributes.Free;
  FKeyAttributes.Free;
  FNumberAttributes.Free;
  FSpaceAttributes.Free;
  FStringAttributes.Free;
  FSymbolAttributes.Free;
  FCommentWithCommandAttributes.Free;
  FEmbeddedCommandAttributes.Free;
  FSystemVariableAttributes.Free;
  FUserVariableAttributes.Free;

  inherited;
end;

//----------------------------------------------------------------------------------------------------------------------

function TUCESQLHighlighter.IsKeyword: Boolean;

// checks whether the current token is a keyword,
// if so then the current token type is set accordingly

var
  Word: string;

begin
  SetString(Word, FInput + FTokenPos, FCurrentPos - FTokenPos);
  FCurrentToken := GetKeywordToken(Word);
  if FCurrentToken > 0 then
  begin
    Result := True;
    FDoStop := True;
  end
  else
    Result := False;
end;

//----------------------------------------------------------------------------------------------------------------------

function TUCESQLHighlighter.EOL: Boolean;

begin
  Result := (FCurrentToken = -1) or FEOL;
end;

//----------------------------------------------------------------------------------------------------------------------

function TUCESQLHighlighter.GetToken: string;

var
  Len: Cardinal;

begin
  Len := FCurrentPos - FTokenPos;
  SetString(Result, FInput + FTokenPos, Len);
end;

//----------------------------------------------------------------------------------------------------------------------

procedure TUCESQLHighlighter.Reset;

begin
  FTokenPos := 0;
  FCurrentPos := 0;
  FCurrentToken := 0;
  FLineState := 1;
  FLastChar := #0;
  FMatchCount := 0;
  FEOL := False;
  ResetRange;
end;

//----------------------------------------------------------------------------------------------------------------------

procedure TUCESQLHighlighter.SetToken(Token: Integer);

begin
  FCurrentToken := Token;
  FDoStop := True;
end;

//----------------------------------------------------------------------------------------------------------------------

procedure TUCESQLHighlighter.RuleToToken(Rule: Integer);

begin
  case Rule of
%%
  end;
end;

//----------------------------------------------------------------------------------------------------------------------

function TUCESQLHighlighter.MatchRule(var Rule: Integer): Boolean;

// finds the last match and the corresponding marked position and adjusts
// the matched string accordingly;
// returns:
// - True if a rule has been matched, False otherwise
// - Rule: the number of the matched rule

begin
  FRejected := False;
  while (FMatchCount > 0) and (FPositions[FMatchStack[FMatchCount - 1]] = 0) do
    Dec(FMatchCount);

  if FMatchCount > 0 then
  begin
    Rule := FMatchStack[FMatchCount - 1];
    FCurrentPos := FTokenPos + FPositions[Rule];
    FPositions[Rule] := 0;
    if (FCurrentPos - FTokenPos) > 0 then
      FLastChar := FInput[FCurrentPos]
    else
      FLastChar := #0;
    Result := True;
  end
  else
  begin
    // return position to starting point
    FCurrentPos := FTokenPos;
    FLastChar := #0;
    Result := False;
  end
end;

//----------------------------------------------------------------------------------------------------------------------

function TUCESQLHighlighter.DoDefault: Boolean;

begin
  FRejected := False;
  if NextChar <> #0 then
    Result := True
  else
  begin
    FLineState := 1;
    Result := False;
  end;
  if not FEOL then
    FLastChar := FInput[FCurrentPos];
end;

//----------------------------------------------------------------------------------------------------------------------

procedure TUCESQLHighlighter.Next;

// scans for the next token and determines its kind (FCurrentToken and FTokenPos
// are set appropriately)

var
  I: Integer;
  Len: Cardinal;
  Matched: Boolean;

begin
  FDoStop := False;

  repeat
    // initialize run
    FTokenPos := FCurrentPos;

    if FLastChar <> #0 then
      if FLastChar = LF then
        FLineState := 1
      else
        FLineState := 0;
    FCurrentState := FStartState + FLineState;

    repeat // character scan loop
      // mark positions and matches
      Len := FCurrentPos - FTokenPos;
      for I := MarksLow[FCurrentState] to MarksHigh[FCurrentState] do
        FPositions[MarkPositionTable[I]] := Len;
      for I := MatchesHigh[FCurrentState] downto MatchesLow[FCurrentState] do
        SetMatch(MatchTable[I]);

      if TransitionsLow[FCurrentState] > TransitionsHigh[FCurrentState] then
        Break; // dead state, do action

      // determine action
      I := TransitionsLow[FCurrentState];
      while (I <= TransitionsHigh[FCurrentState]) and not (FInput[FCurrentPos] in TransitionTable[I].CharClass) do
        Inc(I);

      if I > TransitionsHigh[FCurrentState] then
        Break; // no transition on current char in this state

      // get next character
      NextChar;

      // switch to new state
      FCurrentState := TransitionTable[I].NextState;

    until False;

    repeat
      Matched := MatchRule(I);
      if Matched then
        RuleToToken(I)
      else
        Break;
      // FRejected can be set in RuleToToken by calling Reject
    until Matched and not FRejected;

    if not (Matched or DoDefault) then
    begin
      FStartState := Normal;
      FLineState := 1;
      FLastChar := #0;
      SetToken(0);
    end;
  until FDoStop;
end;

//----------------------------------------------------------------------------------------------------------------------

procedure TUCESQLHighlighter.SetLine(const NewValue: string);

begin
  FInput := PChar(NewValue);
  Reset;
end;

//----------------------------------------------------------------------------------------------------------------------

function TUCESQLHighlighter.GetNextChar: Char;

begin
  if not FEOL and (FInput[FCurrentPos] = #0) then
    FEOL := True;
  Inc(FCurrentPos);
  if not FEOL then
  begin
    FLookahead := FInput[FCurrentPos + 1];
    Result := FInput[FCurrentPos];
  end
  else
    Result := #0;
end;

//----------------------------------------------------------------------------------------------------------------------

procedure TUCESQLHighlighter.SetState(Value: Cardinal);

begin
  FStartState := Value;
end;

//----------------------------------------------------------------------------------------------------------------------

procedure TUCESQLHighlighter.SetMatch(I: Integer);

begin
  if FMatchCount >= Length(FMatchStack) then
    SetLength(FMatchStack, FMatchCount + 1);
  FMatchStack[FMatchCount] := I;
  Inc(FMatchCount);
end;

//----------------------------------------------------------------------------------------------------------------------

procedure TUCESQLHighlighter.Reject;

begin
  FRejected := True;
end;

//----------------------------------------------------------------------------------------------------------------------

function TUCESQLHighlighter.GetTokenInfo: TTokenData;

// Returns token string, token position relative to entire input string, and token length in one call.

begin
  FillChar(Result, SizeOf(Result), 0);
  with Result do
  begin
    if FEOL then
    begin
      Token := StrEnd(FInput);
      Length := Token - FInput - Integer(FTokenPos);
    end
    else
    begin
      Token := FInput + FTokenPos;
      Length := FCurrentPos - FTokenPos;
    end;
    TokenType := FCurrentToken;
    Position := FTokenPos;

    case FCurrentToken of
      SLCOMMENT,
      MLCOMMENT:
        begin
          Background := ColorToRGB(FCommentAttributes.Background);
          Foreground := ColorToRGB(FCommentAttributes.Foreground);
          Style := FCommentAttributes.Style;
        end;
      IDENTIFIER:
        begin
          Background := ColorToRGB(FIdentifierAttributes.Background);
          Foreground := ColorToRGB(FIdentifierAttributes.Foreground);
          Style := FIdentifierAttributes.Style;
        end;
      KEYWORD:
        begin
          Background := ColorToRGB(FKeyAttributes.Background);
          Foreground := ColorToRGB(FKeyAttributes.Foreground);
          Style := FKeyAttributes.Style;
        end;
      FLOATNUMBER,
      INTEGERNUMBER:
        begin
          Background := ColorToRGB(FNumberAttributes.Background);
          Foreground := ColorToRGB(FNumberAttributes.Foreground);
          Style := FNumberAttributes.Style;
        end;
      WHITESPACE:
        begin
          Background := ColorToRGB(FSpaceAttributes.Background);
          Foreground := ColorToRGB(FSpaceAttributes.Foreground);
          Style := FSpaceAttributes.Style;
        end;
      STRINGCONSTANT:
        begin
          Background := ColorToRGB(FStringAttributes.Background);
          Foreground := ColorToRGB(FStringAttributes.Foreground);
          Style := FStringAttributes.Style;
        end;
      SYMBOL:
        begin
          Background := ColorToRGB(FSymbolAttributes.Background);
          Foreground := ColorToRGB(FSymbolAttributes.Foreground);
          Style := FSymbolAttributes.Style;
        end;
      COMMENT_WITH_COMMAND:
        begin
          Background := ColorToRGB(FCommentWithCommandAttributes.Background);
          Foreground := ColorToRGB(FCommentWithCommandAttributes.Foreground);
          Style := FEmbeddedCommandAttributes.Style;
        end;
      EMBEDDED_COMMAND:
        begin
          Background := ColorToRGB(FEmbeddedCommandAttributes.Background);
          Foreground := ColorToRGB(FEmbeddedCommandAttributes.Foreground);
          Style := FEmbeddedCommandAttributes.Style;
        end;
      SYSTEM_VARIABLE:
        begin
          Background := ColorToRGB(FSystemVariableAttributes.Background);
          Foreground := ColorToRGB(FSystemVariableAttributes.Foreground);
          Style := FSystemVariableAttributes.Style;
        end;
      USER_VARIABLE:
        begin
          Background := ColorToRGB(FUserVariableAttributes.Background);
          Foreground := ColorToRGB(FUserVariableAttributes.Foreground);
          Style := FUserVariableAttributes.Style;
        end;
    end;
  end;
end;

//----------------------------------------------------------------------------------------------------------------------

function TUCESQLHighlighter.GetCurrentChar: Char;

begin
  Result := FInput[FCurrentPos];
end;

//----------------------------------------------------------------------------------------------------------------------

procedure TUCESQLHighlighter.HighlightChange(Sender: TObject);

begin
  WindowList.Invalidate;
end;

//----------------------------------------------------------------------------------------------------------------------

function TUCESQLHighlighter.GetIdentChars: TIdentChars;

begin
  Result := ['_', '0'..'9', 'a'..'z', 'A'..'Z'];
end;

//----------------------------------------------------------------------------------------------------------------------

function TUCESQLHighlighter.GetAttributeCount: Integer;

begin
  Result := 7;
end;

//----------------------------------------------------------------------------------------------------------------------

function TUCESQLHighlighter.GetAttribute(Index: Integer): THighlightAttributes;

begin
  case Index of
    0:
      Result := FCommentAttributes;
    1:
      Result := FIdentifierAttributes;
    2:
      Result := FNumberAttributes;
    3:
      Result := FKeyAttributes;
    4:
      Result := FSpaceAttributes;
    5:
      Result := FStringAttributes;
    6:
      Result := FSymbolAttributes;
    7:
      Result := FEmbeddedCommandAttributes;
    8:
      Result := FCommentWithCommandAttributes;
    9:
      Result := FSystemVariableAttributes;
    10:
      Result := FUserVariableAttributes;
  else
    Result := nil;
  end;
end;

//----------------------------------------------------------------------------------------------------------------------

function TUCESQLHighlighter.GetLanguageName: string;

begin
  Result := 'SQL';
end;

//----------------------------------------------------------------------------------------------------------------------

procedure TUCESQLHighlighter.SetAttribute(const Index: Integer; const Value: THighlightAttributes);

begin
  case Index of
    0:
      FCommentAttributes.Assign(Value);
    1:
      FIdentifierAttributes.Assign(Value);
    2:
      FNumberAttributes.Assign(Value);
    3:
      FKeyAttributes.Assign(Value);
    4:
      FSpaceAttributes.Assign(Value);
    5:
      FStringAttributes.Assign(Value);
    6:
      FSymbolAttributes.Assign(Value);
    7:
      FEmbeddedCommandAttributes.Assign(Value);
    8:
      FCommentWithCommandAttributes.Assign(Value);
    9:
      FSystemVariableAttributes.Assign(Value);
    10:
      FUserVariableAttributes.Assign(Value);
  end;
end;

//----------------------------------------------------------------------------------------------------------------------

function TUCESQLHighlighter.GetRange: Integer;

begin
  Result := FStartState;
end;

//----------------------------------------------------------------------------------------------------------------------

function TUCESQLHighlighter.HasMoreTokens: Boolean;
 
begin
  Result := FCurrentToken > -1;
end;
 
//--------------------------------------------------------------------------------
 
procedure TUCESQLHighlighter.SetRange(Value: Integer);

begin
  FStartState := Value;
end;

//----------------------------------------------------------------------------------------------------------------------

procedure TUCESQLHighlighter.ResetRange;

begin
  FStartState := Normal;
  FCurrentState := Normal;
end;

//----------------------------------------------------------------------------------------------------------------------

end.