psvdfm.pas

来自「PIC 单片机 PAS SOURCE CODE SAMPLES」· PAS 代码 · 共 386 行

{*******************************************************}
{               RichEdit Syntax HighLight               }
{                     version 3.0                       }
{ Author:                                               }
{ Serhiy Perevoznyk                                     }
{ [e-mail]                          }
{                                                       }
{*******************************************************}

{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: SynHighlighterDfm.pas, released 2000-04-14.
The Original Code is based on the dmDfmSyn.pas file from the
mwEdit component suite by Martin Waldenburg and other developers, the Initial
Author of this file is David H. Muir.
All Rights Reserved.
The Original Code can be obtained from http://synedit.sourceforge.net/
}

unit psvDFM;


interface

uses
  SysUtils, Windows, Messages, Classes, Controls, Graphics, 
  psvRichSyntax;

type
  TtkTokenKind = (tkComment, tkIdentifier, tkKey, tkNull, tkNumber, tkSpace,
    tkString, tkSymbol, tkUnknown);

  TRangeState = (rsANil, rsComment, rsUnKnown);

  TProcTableProc = procedure of object;

type
  TpsvDFMRTF = class(TpsvRTFSyntax)
  private
    fRange: TRangeState;
    fLine: PChar;
    fLineNumber: Integer;
    fProcTable: array[#0..#255] of TProcTableProc;
    Run: LongInt;
    fTokenPos: Integer;
    FTokenID: TtkTokenKind;
    procedure AltProc;
    procedure AsciiCharProc;
    procedure BraceCloseProc;
    procedure BraceOpenProc;
    procedure CommentProc;
    procedure CRProc;
    procedure EndProc;
    procedure IntegerProc;
    procedure LFProc;
    procedure NullProc;
    procedure NumberProc;
    procedure ObjectProc;
    procedure SpaceProc;
    procedure StringProc;
    procedure SymbolProc;
    procedure UnknownProc;
    procedure MakeMethodTables;
  protected
    function GetEOL: Boolean; override;
    function GetRange: Pointer; 
    function GetTokenID: TtkTokenKind;
    procedure SetLine(NewValue: String; LineNumber: Integer); override;
    function GetToken: String; override;
    function GetTokenAttribute: integer; override;
    function GetTokenKind: integer; 
    function GetTokenPos: Integer; 
    procedure Next; override;
    procedure SetRange(Value: Pointer); 
    procedure ReSetRange; 
    procedure PrepareToken(var AToken : string); override;
    function PrepareOutput(Attr: integer; AToken : string): string; override;
  public
    constructor Create; override;
    procedure SetupDefaultColors; override;
  end;


implementation


{ TpsvDFMRTF }

procedure TpsvDFMRTF.MakeMethodTables;
var
  I: Char;
begin
  for I := #0 to #255 do
    case I of
      '#': fProcTable[I] := AsciiCharProc;
      '}': fProcTable[I] := BraceCloseProc;
      '{': fProcTable[I] := BraceOpenProc;
      #13: fProcTable[I] := CRProc;
      'A'..'Z', 'a'..'z', '_':
        if I in ['e', 'E'] then fProcTable[I] := EndProc
        else if I in ['o', 'O'] then fProcTable[I] := ObjectProc
        else fProcTable[I] := AltProc;
      '$': fProcTable[I] := IntegerProc;
      #10: fProcTable[I] := LFProc;
      #0: fProcTable[I] := NullProc;
      '0'..'9': fProcTable[I] := NumberProc;
      '(', ')', '/', '=', '<', '>', '.', ',', '[', ']':
        fProcTable[I] := SymbolProc;
      #1..#9, #11, #12, #14..#32: fProcTable[I] := SpaceProc;
      #39: fProcTable[I] := StringProc;
    else fProcTable[I] := UnknownProc;
    end;
end;

constructor TpsvDFMRTF.Create;
begin
  inherited Create;
  MakeMethodTables;
  fRange := rsUnknown;
  CreateColorTable([clBlue,
                    clBlack,
                    clBlack,
                    clBlack,
                    clNavy,
                    clBlue,
                    clBlack,
                    clBlack]);
end;

procedure TpsvDFMRTF.SetLine(NewValue: String; LineNumber: Integer);
begin
  fLine := PChar(NewValue);
  Run := 0;
  fLineNumber := LineNumber;
  Next;
end;

procedure TpsvDFMRTF.AltProc;
begin
  fTokenID := tkIdentifier;
  repeat
    Inc(Run);
  until not (fLine[Run] in ['_', '0'..'9', 'a'..'z', 'A'..'Z']);
end;

procedure TpsvDFMRTF.AsciiCharProc;
begin
  fTokenID := tkString;
  repeat
    Inc(Run);
  until not (fLine[Run] in ['0'..'9']);
end;

procedure TpsvDFMRTF.BraceCloseProc;
begin
  inc(Run);
  fRange := rsUnknown;
  fTokenId := tkIdentifier;
end;

procedure TpsvDFMRTF.BraceOpenProc;
begin
  fRange := rsComment;
  CommentProc;
end;

procedure TpsvDFMRTF.CommentProc;
begin
  fTokenID := tkComment;
  repeat
    inc(Run);
    if fLine[Run] = '}' then begin
      Inc(Run);
      fRange := rsUnknown;
      break;
    end;
  until fLine[Run] in [#0, #10, #13];
end;

procedure TpsvDFMRTF.CRProc;
begin
  fTokenID := tkSpace;
  Inc(Run);
  if (fLine[Run] = #10) then Inc(Run);
end;

procedure TpsvDFMRTF.EndProc;
begin
  if (fLine[Run + 1] in ['n', 'N']) and
     (fLine[Run + 2] in ['d', 'D']) and
     not (fLine[Run + 3] in ['_', '0'..'9', 'a'..'z', 'A'..'Z'])
  then begin
    fTokenID := tkKey;
    Inc(Run, 3);
  end else
    AltProc;
end;

procedure TpsvDFMRTF.IntegerProc;
begin
  fTokenID := tkNumber;
  repeat
    inc(Run);
  until not (fLine[Run] in ['0'..'9', 'A'..'F', 'a'..'f']);
end;

procedure TpsvDFMRTF.LFProc;
begin
  fTokenID := tkSpace;
  inc(Run);
end;

procedure TpsvDFMRTF.NullProc;
begin
  fTokenID := tkNull;
end;

procedure TpsvDFMRTF.NumberProc;
begin
  fTokenID := tkNumber;
  repeat
    Inc(Run);
    if fLine[Run] = '.' then begin
      if fLine[Run + 1] <> '.' then Inc(Run);
      break;
    end;
  until not (fLine[Run] in ['0'..'9', 'e', 'E']);
end;

procedure TpsvDFMRTF.ObjectProc;
begin
  if (fLine[Run + 1] in ['b', 'B']) and
     (fLine[Run + 2] in ['j', 'J']) and
     (fLine[Run + 3] in ['e', 'E']) and
     (fLine[Run + 4] in ['c', 'C']) and
     (fLine[Run + 5] in ['t', 'T']) and
     not (fLine[Run + 6] in ['_', '0'..'9', 'a'..'z', 'A'..'Z'])
  then begin
    fTokenID := tkKey;
    Inc(Run, 6);
  end else
    AltProc;
end;

procedure TpsvDFMRTF.SpaceProc;
begin
  fTokenID := tkSpace;
  repeat
    Inc(Run);
  until (fLine[Run] > #32) or (fLine[Run] in [#0, #10, #13]);
end;

procedure TpsvDFMRTF.StringProc;
begin
  fTokenID := tkString;
  repeat
    Inc(Run);
    if fLine[Run] = '''' then begin
      Inc(Run);
      if fLine[Run] <> '''' then break
    end;
  until fLine[Run] in [#0, #10, #13];
end;

procedure TpsvDFMRTF.SymbolProc;
begin
  inc(Run);
  fTokenID := tkSymbol;
end;

procedure TpsvDFMRTF.UnknownProc;
begin
  inc(Run);
  fTokenID := tkUnknown;
end;

procedure TpsvDFMRTF.Next;
begin
  fTokenPos := Run;
  if fRange = rsComment then begin
    if fLine[Run] = #0 then NullProc
                       else CommentProc;
  end else
    fProcTable[fLine[Run]];
end;


function TpsvDFMRTF.GetEol: Boolean;
begin
  Result := fTokenId = tkNull;
end;

function TpsvDFMRTF.GetRange: Pointer;
begin
  Result := Pointer(fRange);
end;

function TpsvDFMRTF.GetTokenID: TtkTokenKind;
begin
  Result := fTokenId;
end;

function TpsvDFMRTF.GetToken: String;
var
  Len: LongInt;
begin
  Len := Run - fTokenPos;
  SetString(Result, (FLine + fTokenPos), Len);
end;

function TpsvDFMRTF.GetTokenAttribute: integer;
begin
  case fTokenID of
    tkComment: Result := 1;
    tkIdentifier: Result := 2;
    tkKey: Result := 3;
    tkNumber: Result := 4;
    tkSpace: Result := 5;
    tkString: Result := 6;
    tkSymbol: Result := 7;
    tkUnknown: Result := 8;
    else Result := 8;
  end;
end;

function TpsvDFMRTF.GetTokenKind: integer;
begin
  Result := Ord(fTokenID);
end;

function TpsvDFMRTF.GetTokenPos: Integer;
begin
  Result := fTokenPos;
end;

procedure TpsvDFMRTF.ResetRange;
begin
  fRange := rsUnknown;
end;

procedure TpsvDFMRTF.SetRange(Value: Pointer);
begin
  fRange := TRangeState(Value);
end;


procedure TpsvDFMRTF.PrepareToken(var AToken : string);
var St : string;
begin
  St := AToken;
  St := StringReplace(St,'\','\\',[rfReplaceAll]);
  St := StringReplace(St,'{','\{',[rfReplaceAll]);
  St := StringReplace(St,'}','\}',[rfReplaceAll]);
  AToken := St;
end;

function TpsvDFMRTF.PrepareOutput(Attr: integer; AToken : string): string;
begin
  case Attr of 
    1 : Result  := '\cf1 \i '+ AToken +'\i0 ';
    3 : Result  := '\cf3 \b '+ AToken +'\b0 ';
  else
   Result := Format('\cf%d %s',[Attr,AToken]);
  end;
end;

procedure TpsvDFMRTF.SetupDefaultColors;
begin
  CreateColorTable([clBlue,
                    clBlack,
                    clBlack,
                    clBlack,
                    clNavy,
                    clBlue,
                    clBlack]);
end;

end.