source: branches/Pascal Compiler 2/USyntaxHighlight.pas

unit USyntaxHighlight;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ComCtrls;


type
  TRuleIndex = (riNormal, riComment, riReservedWord, riNumber, riString,
    riPreprocessor, riAssembler);

  procedure ProcessHighlight(var RichEdit: TRichEdit);

var
  Rules: array[TRuleIndex] of TFont;

implementation

function IsAlfanumeric(Character: Char): Boolean;
begin
  Result := ((Ord(UpperCase(Character)[1]) >= Ord('A')) and (Ord(UpperCase(Character)[1]) <= Ord('Z')))
    or ((Ord(Character) >= Ord('0')) and (Ord(Character) <= Ord('9')));
end;

procedure ProcessHighlight(var RichEdit: TRichEdit);
type
  TBlockState = (msNormalText, msString, msComment1, msComment2, msComment3,
    msComment4, msComment5, msComment6);
var
  Lines: TStringList;
  I: Integer;
  II: Integer;
  BlockState: TBlockState;
//  LastMachineState: TBlockState;
  OneChar: Char;
  LastPosition: TPoint;
const
  ReservedWordList: array[0..80] of string = ('asm', 'begin', 'end', 'procedure', 'function',
    'program', 'while', 'do', 'type', 'var', 'const', 'property', 'object',
    'class', 'constructor', 'destructor', 'virtual', 'abstract', 'override',
    'overload', 'repeat', 'until', 'for', 'to', 'if', 'then', 'else', 'interface',
    'unit', 'implementation', 'initialization', 'finalization', 'private',
    'public', 'published', 'protected', 'absolute', 'default', 'finally', 'try',
    'except', 'index', 'case', 'exports', 'and', 'or', 'xor', 'not', 'array',
    'record', 'as', 'is', 'div', 'downto', 'goto', 'final', 'file', 'inherited',
    'inline', 'label', 'library', 'mod', 'nil', 'of', 'out', 'in', 'packed',
    'raise', 'resourcestring', 'sealed', 'set', 'shl', 'shr', 'static', 'string',
    'threadvar', 'unsafe', 'uses', 'with', 'read', 'write');
begin
  Lines := TStringList.Create;
  Lines.Assign(RichEdit.Lines);
  LastPosition := RichEdit.CaretPos;
  RichEdit.Lines.BeginUpdate;
  RichEdit.Lines.Clear;
  BlockState := msNormalText;
  I := 1;
  while (I < Length(Lines.Text)) do begin
    case BlockState of
      msNormalText: begin
        II := 0;
        while (II < Length(ReservedWordList)) do begin
          if (ReservedWordList[II] = Copy(Lines.Text, I,
            Length(ReservedWordList[II]))) and
            (not IsAlfanumeric(Lines.Text[I + Length(ReservedWordList[II])])) and
            (not IsAlfanumeric(Lines.Text[I - 1])) then begin
              Break;
            end;
          Inc(II);
        end;
        if II < Length(ReservedWordList) then begin
          RichEdit.SelAttributes.Assign(Rules[riReservedWord]);
          RichEdit.SelText := ReservedWordList[II];
          RichEdit.SelAttributes.Assign(Rules[riNormal]);
          Inc(I, Length(ReservedWordList[II]));
        end else begin
          if (Lines.Text[I] = '{') then begin
            RichEdit.SelAttributes.Assign(Rules[riComment]);
            BlockState := msComment1;
            RichEdit.SelText := Lines.Text[I];
            Inc(I, 1);
          end else
          if (Copy(Lines.Text, I, 2) = '(*') then begin
            RichEdit.SelAttributes.Assign(Rules[riComment]);
            BlockState := msComment2;
            RichEdit.SelText := '(*';
            Inc(I, 2);
          end else
          if (Copy(Lines.Text, I, 2) = '//') then begin
            RichEdit.SelAttributes.Assign(Rules[riComment]);
            BlockState := msComment3;
            RichEdit.SelText := '//';
            Inc(I, 2);
          end else
          if Lines.Text[I] = '''' then begin
            RichEdit.SelAttributes.Assign(Rules[riString]);
            BlockState := msString;
            RichEdit.SelText := Lines.Text[I];
            Inc(I, 1);
          end else begin
            RichEdit.SelText := Lines.Text[I];
            Inc(I);
          end;
        end;
      end;
      msString: begin
        if Lines.Text[I] = '''' then begin
          RichEdit.SelText := Lines.Text[I];
          RichEdit.SelAttributes.Assign(Rules[riNormal]);
          Inc(I, 1);
          BlockState := msNormalText;
        end else begin
          RichEdit.SelText := Lines.Text[I];
          Inc(I, 1);
        end;
      end;
      msComment1: begin
        if Lines.Text[I] = '}' then begin
          RichEdit.SelText := '}';
          Inc(I, 1);
          RichEdit.SelAttributes.Assign(Rules[riNormal]);
          BlockState := msNormalText;
        end else begin
          RichEdit.SelText := Lines.Text[I];
          Inc(I, 1);
        end;
      end;
      msComment2: begin
        if (Copy(Lines.Text, I, 2) = '*)') then begin
          BlockState := msNormalText;
          RichEdit.SelText := '*)';
          Inc(I, 2);
          RichEdit.SelAttributes.Assign(Rules[riNormal]);
        end else begin
          RichEdit.SelText := Lines.Text[I];
          Inc(I, 1);
        end;
      end;
      msComment3: begin
        if (Lines.Text[I] = #10) or (Lines.Text[I] = #13) then begin
          RichEdit.SelText := Lines.Text[I];
          RichEdit.SelAttributes.Assign(Rules[riNormal]);
          BlockState := msNormalText;
          Inc(I, 2);
        end else begin
          RichEdit.SelText := Lines.Text[I];
          Inc(I, 1);
        end;
      end;
    end;
  end;
  RichEdit.Lines.EndUpdate;
  RichEdit.CaretPos := LastPosition;
  Lines.Free;
end;

initialization

Rules[riNormal] := TFont.Create;
with Rules[riNormal] do begin
  Name := 'Courier New';
  Size := 10;
end;
Rules[riComment] := TFont.Create;
with Rules[riComment] do begin
  Assign(Rules[riNormal]);
  Color := clBlue;
  Style := [fsItalic];
end;
Rules[riString] := TFont.Create;
with Rules[riString] do begin
  Assign(Rules[riNormal]);
  Color := clGreen;
end;
Rules[riNumber] := TFont.Create;
with Rules[riNumber] do begin
  Assign(Rules[riNormal]);
end;
Rules[riAssembler] := TFont.Create;
with Rules[riAssembler] do begin
  Assign(Rules[riNormal]);
  Color := clRed;
end;
Rules[riPreprocessor] := TFont.Create;
with Rules[riPreprocessor] do begin
  Assign(Rules[riNormal]);
  Style := [fsItalic];
end;
Rules[riReservedWord] := TFont.Create;
with Rules[riReservedWord] do begin
  Assign(Rules[riNormal]);
  Style := [fsBold];
end;

end.