Code:
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, Menus, StdCtrls, ComCtrls, TOMRichEdit, tom_TLB, contnrs;
const
PascalKeywords : array [0..105] of widestring = (
{reserved words}
'and', 'array', 'as', 'asm', 'begin', 'case', 'class', 'const',
'constructor', 'destructor', 'dispinterface', 'div', 'do',
'downto', 'else', 'end', 'except', 'exports', 'file',
'finalization', 'finally', 'for', 'function', 'goto', 'if',
'implementation', 'in', 'inherited', 'initialization', 'inline',
'interface', 'is', 'label', 'library', 'mod', 'nil', 'not',
'object', 'of', 'or', 'out', 'packed', 'procedure', 'program',
'property', 'raise', 'record', 'repeat', 'resourcestring', 'set',
'shl', 'shr', 'string', 'then', 'threadvar', 'to', 'try', 'type',
'unit', 'until', 'uses', 'var', 'while', 'with', 'xor',
{directives}
'absolute', 'abstract', 'assembler', 'automated', 'cdecl',
'contains', 'default', 'dispid', 'dynamic', 'export', 'external',
'far', 'forward', 'implements', 'index', 'message', 'name',
'near', 'nodefault', 'overload', 'override', 'package', 'pascal',
'private', 'protected', 'public', 'published', 'read', 'readonly',
'register', 'reintroduce', 'requires', 'resident', 'safecall',
'stdcall', 'stored', 'virtual', 'write', 'writeonly',
{others}
'at', 'on'
);
type
TParseRecord = record
ML1Start:widestring; //Multiline comment
ML1End:widestring;
ML2Start:widestring; //Multiline comment alternative
ML2End:widestring;
DvStart:widestring; //Directive
DvEnd:widestring;
SL:widestring; //Single line color
SD:String;
DefaultColor,
CommentColor,
DirectiveColor,
KeywordColor:TColor;
end;
type
// simple hashed stringlist. Uses a fast elfhash (in BASM)
// and linear probing to find a string element.
// Fast but not finished (Objects property needs to be guarded from use)
THashedStringlist = class(Tstringlist)
public
constructor create;virtual;
function IndexOf(const S: string): Integer;override;
procedure Insert(Index: Integer; const S: string);override;
function Add(const S:string):integer;override;
end;
type
TForm1 = class(TForm)
MainMenu1: TMainMenu;
TOMRichEdit1: TTOMRichEdit;
File1: TMenuItem;
Exit1: TMenuItem;
N1: TMenuItem;
Open1: TMenuItem;
Options1: TMenuItem;
Highlight1: TMenuItem;
OpenDialog1: TOpenDialog;
procedure Exit1Click(Sender: TObject);
procedure Open1Click(Sender: TObject);
procedure Highlight1Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
private
KeyWords:THashedStringlist;
PascalRecord:TParseRecord;
public
{ Public declarations }
procedure HighLight;
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
// Fast: only 7 cycles per round....
function ElfHash(const s: string): Tobject;
asm
mov edx, eax
xor eax, eax
test edx, edx
jz @Ret
sub eax, [edx-4]
jz @Ret
mov ecx, eax
sub edx, eax
xor eax, eax
push ebx
@Loop:
movzx ebx, [edx+ecx]
add ebx, eax
lea eax, [ebx+ebx]
shr ebx, 20
lea eax, [8*eax]
and ebx, $0F00
xor eax, ebx
add ecx, 1
jnz @Loop
shr eax, 4
pop ebx
@Ret:
end;
procedure TForm1.Exit1Click(Sender: TObject);
begin
Application.Terminate;
end;
procedure TForm1.Open1Click(Sender: TObject);
var
fn:OleVariant;
begin
if Opendialog1.execute then
begin
fn:=OpenDialog1.FileName;
TomRichedit1.document.Open(fn,0,0);
end;
end;
procedure TForm1.Highlight1Click(Sender: TObject);
begin
HighLight;
end;
procedure Tform1.highlight;
var
Token:Widestring;
I:Integer;
Clone:ITextRange;
begin
Clone:=TomRichEdit1.Document.Selection.Duplicate;
i:=Clone.start;
Clone.font.Style:=-2;
while 1=1 do
with Clone, PascalRecord do
begin
if Boolean(MoveEnd(tomWord,1))=false then break;
Token:=trim(lowercase(text));
// single line comment, if applicable
// Note that the order in which the text is parsed is very important!
if ( length(SL)>0 )and (system.copy(Token,1,length(SL)) = SL) then
begin
FindTextEnd(#13,tomForward,0);
Font.ForeColor:=CommentColor;
setrange(end_,end_);
end
else
// Directive, if applicable
if ( length(DVStart)>0 ) and (system.copy(Token,1,Length(DvStart)) =DvStart) then
begin
if DvEnd <> '' then
FindTextEnd(DvEnd,tomForward,0)
else
MoveEnd(tomWord,1);
Clone.font.ForeColor:=DirectiveColor;
setrange(end_,end_);
end
// multiline comment type 1, if applicable
else
if( length(ML1Start)>0 ) and (system.copy(Token,1,Length(ML1start)) = ML1Start) then
begin
SetRange(start,start);
FindTextEnd(ML1End,tomForward,0);
Font.ForeColor:=CommentColor;
SetRange(end_,end_);
end
// multiline comment type 2, if applicable
else
if ( length(ML2Start)>0 ) and (system.copy(Token,1,Length(ML2start)) = ML2Start) then
begin
SetRange(start,start);
FindTextEnd(ML2End,tomForward,0);
Font.ForeColor:=CommentColor;
SetRange(end_,end_);
end
else
// keywords
begin
// poor man's hashmap using linear probing to find the key.
if Keywords.IndexOf(Token) >= 0 then
begin
Clone.font.forecolor:=KeywordColor;
Clone.Font.Bold:=integer(tomTrue);
end else
Clone.font.forecolor:=DefaultColor;
movestart(tomword,1);
end;
Application.ProcessMessages;
end;
Clone.Setrange(i,i);
end;
procedure TForm1.FormCreate(Sender: TObject);
var
i:integer;
begin
Keywords:=THashedStringlist.Create;
for i:= Low(PascalKeyWords) to High(PascalKeyWords) do
begin
KeyWords.Add(PascalKeywords[i]);
end;
with PascalRecord do
begin
ML1Start := '{';
ML1End := '}';
ML2Start := '(*';
ML2End := '*)';
DVStart := '{$';
DVEnd := '}';
SL := '//';
SD := #39;
DefaultColor := ClBlack;
CommentColor := clNavy;
DirectiveColor:= clGreen;
KeywordColor := clBlack
end;
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
Keywords.Free;
end;
{ THashedStringlist }
function THashedStringlist.Add(const S: string): integer;
begin
Result := GetCount;
Insert(Result, S);
end;
constructor THashedStringlist.create;
begin
inherited create;
Duplicates:=dupError;
end;
function THashedStringlist.IndexOf(const S: string): Integer;
begin
result:=IndexOfObject(ElfHash(Lowercase(s)));
end;
procedure THashedStringlist.Insert(Index: Integer; const S: string);
begin
inherited;
Objects[index]:=ElfHash(Lowercase(S));
end;
end.
Form:
Bookmarks