syngenu.pas

来自「本人买的<<VC++项目开发实例>>源代码配套光盘.」· PAS 代码 · 共 1,035 行 · 第 1/3 页

procedure TGenFrm.BtnStartClick(Sender: TObject);
begin
  if OpenDialog.Execute then
  begin
    Stream.Clear;
    Stream.LoadFromFile(OpenDialog.FileName);
    Lex.Origin := Stream.Memory;
    Lex.Tokenize;
    while Lex.RunId <> IDIdentifier do Lex.Next;
    LexName := Lex.RunToken;
    Lex.Next;
    while Lex.RunId <> IDIdentifier do Lex.Next;
    IdentPre := Lex.RunToken;
    OutFileCreate(OpenDialog.FileName);
    while not (Lex.RunId in [IdSensitive, IdIdentStart]) do Lex.Next;
    if Lex.RunId = IdSensitive then Sensitivity := True else Sensitivity := False;
    Lex.Next;
    while Lex.RunId <> IDCharSet do Lex.Next;
    IdentStart := Lex.RunToken;
    Lex.Next;
    while Lex.RunId <> IDCharSet do Lex.Next;
    IdentContent := Lex.RunToken;
    while Lex.RunId <> IDKeys do Lex.Next;
    FillKeyList;
    while Lex.RunId <> IDChars do Lex.Next;
    ParseCharsets;
    WriteRest;
    while Lex.RunId <> IdNull do
    begin
      Lex.Next;
    end;
    CloseFile(OutFile);
  end;
  Close;
end;

procedure TGenFrm.FillKeyList;
var
  aLexKey: TLexKeys;
  aString: String;
begin
  Lex.Next;
  while Lex.RunId <> IdStop do
  begin
    while Lex.RunId in [IdSpace, IdBraceOpen, IdCRLF] do Lex.Next;
    if Lex.RunId <> IdStop then
    begin
      aString:= '';
      while not (Lex.RunId in [IdSpace, IdBraceOpen, IdCRLF]) do
      begin
        aString:= aString + Lex.RunToken;
        Lex.Next;
      end;
      aLexKey := TLexKeys.Create;
      aLexKey.KeyName := aString;
      if Sensitivity then aLexKey.Key := SensKeyHash(aLexKey.KeyName) else
        aLexKey.Key := KeyHash(aLexKey.KeyName);
      KeyList.Add(aLexKey);
    end else break;
    Lex.Next;
  end;
  Lex.Next;
  while Lex.RunId <> IdStop do
  begin
    while Lex.RunId in [IdSpace, IdBraceOpen, IdCRLF, IDUnknown] do Lex.Next;
    if Lex.RunId <> IdStop then IdentList.Add(IdentPre + Lex.RunToken) else break;
    Lex.Next;
  end;
  KeyList.Sort(CompareKeys);
end;

procedure TGenFrm.OutFileCreate(InName: String);
var
  OutName, UName: String;
begin
  OutName := ExtractFileName(InName);
  Delete(OutName, Length(OutName) - 3, 4);
  Uname := OutName;
  OutName := OutName + '.pas';
  AssignFile(OutFile, OutName);
  rewrite(OutFile);
  Writeln(OutFile, 'unit ' + Uname + ';' + #13#10);
  Writeln(OutFile, '{$I mwEdit.inc}'#13#10);                                    //mh 1999-12-03
  Writeln(OutFile, 'interface' + #13#10);
  Writeln(OutFile, 'uses');
  Writeln(OutFile, '  SysUtils, Windows, Messages, Classes, Controls, Graphics, Registry,');
  Writeln(OutFile, '  mwHighlighter, mwExport, mwLocalStr;' + #13#10);
{begin}                                                                         //mh 1999-11-01
//  Writeln(OutFile, 'var');
//  Writeln(OutFile, '  Identifiers: array[#0..#255] of ByteBool;');
//  Writeln(OutFile, '  mHashTable: array[#0..#255] of Integer;' + #13#10);
{end}                                                                           //mh 1999-11-01
  Writeln(OutFile, 'Type');
  Writeln(OutFile, '  T' + IdentPre + 'TokenKind = (');
end;

procedure TGenFrm.ParseCharsets;
begin
  Lex.Next;
  while Lex.RunId <> IdStop do
  begin
    Case Lex.RunId of
      IdCharset: RetriveCharset;
    else Lex.Next;
    end;
  end;
end;

procedure TGenFrm.RetriveCharset;
var
  aSet: TLexCharsets;
begin
  aSet := TLexCharsets.Create;
  aSet.Charset := Lex.RunToken;
  while Lex.RunId <> IDIdentifier do Lex.Next;
  aSet.SetName := Lex.RunToken;
  while Lex.RunId <> IDBeginProc do Lex.Next;
  Lex.Next;
  while Lex.RunId in [IdCRLF, IdSpace]do Lex.Next;
  while not(Lex.RunId=IdEndProc)do
  begin
    aSet.ProcData:=aSet.ProcData+Lex.RunToken;
    Lex.Next;
  end;
  SetList.Add(aSet);
  Lex.Next;
end;

procedure TGenFrm.WriteRest;
var
  I                                                                 : Integer;
  KeyString, NameString, Space, Tags, AttrName, FilterName, LangName: string;
begin
  IdentList.Sort;
  SetList.Sort(CompareSets);
  I := 0;
  while I < IdentList.Count - 1 do
  begin
    Writeln(OutFile, '    ' + IdentList[I] + ',');
    inc(I);
  end;
  Writeln(OutFile, '    ' + IdentList[I] + ');');
  Writeln(OutFile, '');
  Writeln(OutFile, '  TRangeState = (rsUnknown);');
  Writeln(OutFile, '');
  Writeln(OutFile, '  TProcTableProc = procedure of Object;');
  Writeln(OutFile, '');
  Writeln(OutFile, '  PIdentFuncTableFunc = ^TIdentFuncTableFunc;');            //mh 1999-12-03
  Writeln(OutFile, '  TIdentFuncTableFunc = function: T' + IdentPre + 'TokenKind of Object;');
  Writeln(OutFile, '');
  Writeln(OutFile, 'type');
  Writeln(OutFile, '  ' + LexName + ' = class(TmwCustomHighLighter)');
  Writeln(OutFile, '  private');
  Writeln(OutFile, '    fRange: TRangeState;');
  Writeln(OutFile, '    fLine: PChar;');
  Writeln(OutFile, '    fLineNumber: Integer;');
  Writeln(OutFile, '    fExporter: TmwCustomExport;');
  Writeln(OutFile, '    fProcTable: array[#0..#255] of TProcTableProc;');
  Writeln(OutFile, '    Run: LongInt;');
//  Writeln(OutFile, '    fRoundCount: Integer;');                              //mh 1999-12-03
  Writeln(OutFile, '    fStringLen: Integer;');
  Writeln(OutFile, '    fToIdent: PChar;');
  Writeln(OutFile, '    fTokenPos: Integer;');
  Writeln(OutFile, '    FTokenID: TtkTokenKind;');
  KeyString := IntToStr(TLexKeys(KeyList[KeyList.Count - 1]).Key);
  Writeln(OutFile, '    fIdentFuncTable: array[0..' + KeyString + '] of TIdentFuncTableFunc;');

  I := 0;
  while I < IdentList.Count do
  begin
    if (IdentList[I] <> IdentPre + 'Null') and (IdentList[I] <> IdentPre + 'Unknown') then
      Writeln(OutFile, '    f' + Copy(IdentList[I], Length(IdentPre) + 1, Length(IdentList[I])) + 'Attri: TmwHighLightAttributes;');
    inc(I);
  end;

  Writeln(OutFile, '    function KeyHash(ToHash: PChar): Integer;');
  Writeln(OutFile, '    function KeyComp(const aKey: String): Boolean;');

  I := 0;
  while I < KeyList.Count do
  begin
    if I = 0 then
      Writeln(OutFile, '    function Func' + IntToStr(TLexKeys(KeyList[I]).Key) + ': T' + IdentPre + 'TokenKind;') else
      if (TLexKeys(KeyList[I - 1]).Key <> TLexKeys(KeyList[I]).Key) then
        Writeln(OutFile, '    function Func' + IntToStr(TLexKeys(KeyList[I]).Key) + ': T' + IdentPre + 'TokenKind;');
    inc(I);
  end;

  I := 0;
  while I < SetList.Count do
  begin
    Writeln(OutFile, '    procedure ' + TLexCharsets(SetList[I]).SetName + 'Proc;');
    inc(I);
  end;

  Writeln(OutFile, '    procedure UnknownProc;');
  Writeln(OutFile, '    function AltFunc: T' + IdentPre + 'TokenKind;');
  Writeln(OutFile, '    procedure InitIdent;');
  Writeln(OutFile, '    function IdentKind(MayBe: PChar): T' + IdentPre + 'TokenKind;');
  Writeln(OutFile, '    procedure MakeMethodTables;');
  Writeln(OutFile, '  protected');
  Writeln(OutFile, '    function GetIdentChars: TIdentChars; override;');
  Writeln(OutFile, '    function GetLanguageName: string; override;');
  Writeln(OutFile, '    function GetCapability: THighlighterCapability; override;');
  Writeln(OutFile, '  public');
  Writeln(OutFile, '    constructor Create(AOwner: TComponent); override;');
  Writeln(OutFile, '    function GetEOL: Boolean; override;');
  Writeln(OutFile, '    function GetRange: Pointer; override;');
  Writeln(OutFile, '    function GetTokenID: TtkTokenKind;');
  Writeln(OutFile, '    procedure SetLine(NewValue: String; LineNumber: Integer); override;');
  Writeln(OutFile, '    procedure ExportNext; override;');
  Writeln(OutFile, '    procedure SetLineForExport(NewValue: String); override;');
  Writeln(OutFile, '    function GetToken: String; override;');
  Writeln(OutFile, '    function GetTokenAttribute: TmwHighLightAttributes; override;');
  Writeln(OutFile, '    function GetTokenKind: integer; override;');
  Writeln(OutFile, '    function GetTokenPos: Integer; override;');
  Writeln(OutFile, '    procedure Next; override;');
  Writeln(OutFile, '    procedure SetRange(Value: Pointer); override;');
  Writeln(OutFile, '    procedure ReSetRange; override;');
  Writeln(OutFile, '    property IdentChars;');
  Writeln(OutFile, '  published');

  I := 0;
  while I < IdentList.Count do
  begin
    if (IdentList[I] <> IdentPre + 'Null') and (IdentList[I] <> IdentPre + 'Unknown') then
      Writeln(OutFile, '    property ' + Copy(IdentList[I], Length(IdentPre) + 1, Length(IdentList[I]))
      + 'Attri: TmwHighLightAttributes read f' + Copy(IdentList[I], Length(IdentPre) + 1, Length(IdentList[I])) +
      'Attri write f' + Copy(IdentList[I], Length(IdentPre) + 1, Length(IdentList[I]))+ 'Attri;');
    inc(I);
  end;

  Writeln(OutFile, '    property Exporter:TmwCustomExport read FExporter write FExporter;');
  Writeln(OutFile, '  end;');
  Writeln(OutFile, '');
  Writeln(OutFile, 'procedure Register;');
  Writeln(OutFile, '');
  Writeln(OutFile, 'implementation');
  Writeln(OutFile, '');
  Writeln(OutFile, 'procedure Register;');
  Writeln(OutFile, 'begin');
  Writeln(OutFile, '  RegisterComponents(MWS_HighlightersPage, [' + LexName + ']);');
  Writeln(OutFile, 'end;'#13#10);
{begin}                                                                         //mh 1999-11-01
  Writeln(OutFile, 'var');
  Writeln(OutFile, '  Identifiers: array[#0..#255] of ByteBool;');
  Writeln(OutFile, '  mHashTable: array[#0..#255] of Integer;'#13#10);
{end}                                                                           //mh 1999-11-01
  if Sensitivity then
  begin
    Writeln(OutFile, 'procedure MakeIdentTable;');
    Writeln(OutFile, 'var');
    Writeln(OutFile, '  I: Char;');
    Writeln(OutFile, 'begin');
    Writeln(OutFile, '  for I := #0 to #255 do');
    Writeln(OutFile, '  begin');
    Writeln(OutFile, '    Case I of');
    Writeln(OutFile, '      ' + IdentContent + ': Identifiers[I] := True;');
    Writeln(OutFile, '      else Identifiers[I] := False;');
    Writeln(OutFile, '    end;');
    Writeln(OutFile, '    Case I in [''_'', ''A''..''Z'', ''a''..''z''] of');
    Writeln(OutFile, '      True:');
    Writeln(OutFile, '        begin');
    Writeln(OutFile, '          if (I > #64) and (I < #91) then mHashTable[I] := Ord(I) - 64 else');
    Writeln(OutFile, '            if (I > #96) then mHashTable[I] := Ord(I) - 95;');
    Writeln(OutFile, '        end;');
    Writeln(OutFile, '      else mHashTable[I] := 0;');
    Writeln(OutFile, '    end;');
    Writeln(OutFile, '  end;');
    Writeln(OutFile, 'end;');
    Writeln(OutFile, '');
  end else
  begin
    Writeln(OutFile, 'procedure MakeIdentTable;');
    Writeln(OutFile, 'var');
    Writeln(OutFile, '  I, J: Char;');
    Writeln(OutFile, 'begin');
    Writeln(OutFile, '  for I := #0 to #255 do');
    Writeln(OutFile, '  begin');
    Writeln(OutFile, '    Case I of');
    Writeln(OutFile, '      ' + IdentContent + ': Identifiers[I] := True;');
    Writeln(OutFile, '      else Identifiers[I] := False;');
    Writeln(OutFile, '    end;');
    Writeln(OutFile, '    J := UpCase(I);');                                    //mh 1999-12-03
    Writeln(OutFile, '    Case I in [''_'', ''A''..''Z'', ''a''..''z''] of');
    Writeln(OutFile, '      True: mHashTable[I] := Ord(J) - 64');
    Writeln(OutFile, '      else mHashTable[I] := 0;');
    Writeln(OutFile, '    end;');
    Writeln(OutFile, '  end;');
    Writeln(OutFile, 'end;');
    Writeln(OutFile, '');
  end;

  Writeln(OutFile, 'procedure ' + LexName + '.InitIdent;');
  Writeln(OutFile, 'var');
  Writeln(OutFile, '  I: Integer;');
  Writeln(OutFile, '  pF: PIdentFuncTableFunc;');                               //mh 1999-12-03
  Writeln(OutFile, 'begin');
  Writeln(OutFile, '  pF := PIdentFuncTableFunc(@fIdentFuncTable);');           //mh 1999-12-03
  Writeln(OutFile, '  for I := Low(fIdentFuncTable) to High(fIdentFuncTable) do begin');
  Writeln(OutFile, '    pF^ := AltFunc;');
  Writeln(OutFile, '    Inc(pF);');
  Writeln(OutFile, '  end;');

  I := 0;
  while I < KeyList.Count do
  begin
    if I < KeyList.Count - 1 then
      while TLexKeys(KeyList[I]).Key = TLexKeys(KeyList[I + 1]).Key do
      begin
        inc(I);
        if I >= KeyList.Count - 1 then break;
      end;
    KeyString := IntToStr(TLexKeys(KeyList[I]).Key);
    Writeln(OutFile, '  fIdentFuncTable[' + KeyString + '] := Func' + KeyString + ';');
    inc(I);
  end;

  Writeln(OutFile, 'end;');
  Writeln(OutFile, '');

  Writeln(OutFile, 'function ' + LexName + '.KeyHash(ToHash: PChar): Integer;');
  Writeln(OutFile, 'begin');
  Writeln(OutFile, '  Result := 0;');
  Writeln(OutFile, '  while ToHash^ in [' + IdentContent + '] do');
  Writeln(OutFile, '  begin');
  Writeln(OutFile, '    inc(Result, mHashTable[ToHash^]);');
  Writeln(OutFile, '    inc(ToHash);');
  Writeln(OutFile, '  end;');
  Writeln(OutFile, '  fStringLen := ToHash - fToIdent;');
  Writeln(OutFile, 'end;');
  Writeln(OutFile, '');

  if Sensitivity then
  begin
    Writeln(OutFile, 'function ' + LexName + '.KeyComp(const aKey: String): Boolean;');
    Writeln(OutFile, 'var');
    Writeln(OutFile, '  I: Integer;');
    Writeln(OutFile, '  Temp: PChar;');
    Writeln(OutFile, 'begin');
    Writeln(OutFile, '  Temp := fToIdent;');
    Writeln(OutFile, '  if Length(aKey) = fStringLen then');
    Writeln(OutFile, '  begin');
    Writeln(OutFile, '    Result := True;');
    Writeln(OutFile, '    for i := 1 to fStringLen do');