compiler.pas

H++编译器: 一个仿Pascal语言的编译器

unit Compiler;

interface

uses SysUtils, Classes, Errors;

const
  MaxArgs = 15;

type
  TParams = Array[0..MaxArgs] of String;
  
  PMsg = ^TVMsg;
  TVMsg = record
    Description: String;
    CurrFile: String;
    LineNum: Integer;
  end;

  TPartType = (ptFunction, ptLabel, ptIf, ptWhile, ptDLLFunc, ptFuncLabel);
  PPart = ^TPart;
  TPart = record
    SAssign: String;
    DLL: String;
    Func: String;
    IsFunc, IsNot: Boolean;
    Params: TParams;
    ParamCount: Integer;
    CurrFile: String;
    LineNum: Integer;
    Offset: LongWord;
    Done: Boolean;
    Extra: String;
    PartType: TPartType;
  end;

  TListEx = class(TList)
  public
    procedure InsertItems(Index: Integer; xItems: TListEx);
  end;

  TParser = class
  public
    CanMsg: Boolean;
    Errors: TList;
    Parts: TListEx;
    Warnings: TList;
    constructor Create;
    procedure AddMsg(Description, Filename: String; Line: Integer; Error: Boolean = True);
    procedure Parse(Filename: String);
    destructor Destroy; override;
  end;

implementation

procedure TListEx.InsertItems(Index: Integer; xItems: TListEx);
var
  pr: TList;
  i: Integer;
begin
  pr := TList.Create;
  for i := 0 to Index - 1 do
    pr.Add(Items[i]);
  for i := 0 to xItems.Count - 1 do
    pr.Add(xItems[i]);
  for i := Index + 1 to Count - 1 do
    pr.Add(Items[i]);
  Clear;
  Assign(pr);
end;

constructor TParser.Create;
begin
  inherited;
  Errors := TList.Create;
  Parts := TListEx.Create;
  Warnings := TList.Create;
end;

procedure TParser.AddMsg(Description, Filename: String; Line: Integer; Error: Boolean = True);
var
  Msg: PMsg;
begin
  if CanMsg then
  begin
    CanMsg := False;
    New(Msg);
    Msg.Description := Description;
    Msg.CurrFile := Filename;
    Msg.LineNum := Line;
    if Error then
      Errors.Add(Msg)
    else
      Warnings.Add(Msg);
  end;
end;

procedure TParser.Parse(Filename: String);
  var
    CurrFile,S: String;
    CurrLn: Integer;
    CFile: TextFile;
  procedure AddMessage(Description: String; Error: Boolean = True);
    var
      Msg: PMsg;
  begin
    New(Msg);
    Msg.Description := Description;
    Msg.CurrFile := CurrFile;
    Msg.LineNum := CurrLn;
    if Error then
      Errors.Add(Msg)
    else
      Warnings.Add(Msg);
  end;
  procedure ParseLine(Line: String);
    var
      i, lp, pl: Integer;
      p: TParams;
      Rec: PPart;
      inStr, isStarted, isEnded, inBracks, hasAlfa, isIn: Boolean;
    procedure AddParam(Str: String);
    begin
      if Trim(Str) <> '' then
      begin
        p[pl] := Trim(Str);
        Inc(pl);
      end;
    end;
  begin
    i := 1;
    lp := 1;
    pl := 0;
    inStr := False;
    isStarted := False;
    isEnded := False;
    inBracks := False;
    hasAlfa := False;
    isIn := False;
    New(Rec);
    Rec.PartType := ptFunction;
    Rec.IsFunc := False;
    Rec.IsNot := False;
    while i <= Length(Line) do
    begin
      if ((Copy(LowerCase(Line),i,3) = 'if ') or (Copy(LowerCase(Line),i,6) = 'ifnot ')) and not isStarted then
      begin
        isStarted := True;
        Rec.PartType := ptIf;
        if Copy(LowerCase(Line),i,6) = 'ifnot ' then
        begin
          Rec.IsNot := True;
          i := i + 3;
        end;
        i := i + 3;
        lp := i;
      end
      else if ((Copy(LowerCase(Line),i,6) = 'while ') or (Copy(LowerCase(Line),i,9) = 'whilenot ')) and not isStarted then
      begin
        isStarted := True;
        Rec.PartType := ptWhile;
        if Copy(LowerCase(Line),i,9) = 'whilenot ' then
        begin
          Rec.IsNot := True;
          i := i + 3;
        end;
        i := i + 6;
        lp := i;
      end
      else if (Copy(LowerCase(Line),i,9) = 'function ') and not isStarted then
      begin
        isStarted := True;
        Rec.PartType := ptFuncLabel;
        i := i + 9;
        lp := i;
      end
      else if (Copy(LowerCase(Line),i,6) = ' goto ') and ((Rec.PartType = ptIf) or (Rec.PartType = ptWhile)) then
      begin
        if isIn and (Line[i-1] = ']') then
          Rec.Func := Rec.Func+','+Trim(Copy(Line,lp,i-lp-1))
        else
          Rec.Func := Trim(Copy(Line,lp,i-lp));
        i := i + 6;
        lp := i;
      end
      else if (Copy(Line,i,5) = ' in [') and not inStr and ((Rec.PartType = ptIf) or (Rec.PartType = ptWhile)) then
      begin
        isIn := True;
        Rec.SAssign := Trim(Copy(Line,lp,i-lp));
        Rec.DLL := 'in';
        i := i + 5;
        lp := i;
      end
      else if (Copy(Line,i,2) = '..') and not inStr and ((Rec.PartType = ptIf) or (Rec.PartType = ptWhile)) then
      begin
        isStarted := True;
        Rec.Func := Trim(Copy(Line,lp,i-lp));
        i := i + 2;
        lp := i;
      end
      else if (Copy(LowerCase(Line),i,5) = 'begin') and not isStarted then
      begin
        isStarted := True;
        isEnded := True;
        Rec.Func := 'begin';
        i := Length(Line) + 1;
      end
      else if (Copy(LowerCase(Line),i,4) = 'stub') and not isStarted then
      begin
        isStarted := True;
        isEnded := True;
        Rec.Func := 'stub';
        i := Length(Line) + 1;
      end
      else if Line[i] = '''' then
      begin
        inStr := not inStr;
        Inc(i);
      end
      else if (Line[i] = '=') and not inStr then
      begin
        isStarted := True;
        Rec.SAssign := Trim(Copy(Line,lp,i-lp));
        Rec.DLL := Line[i];
        if Line[i+1] = '+' then
        begin
          Inc(i);
          Rec.Func := Rec.SAssign + '+';
        end
        else if Line[i+1] = '-' then
        begin
          Inc(i);
          Rec.Func := Rec.SAssign + '-';
        end;
        i := i + 1;
        lp := i;
      end
      else if ((Line[i] = '>') or (Line[i] = '<')) and not inStr then
      begin
        isStarted := True;
        Rec.SAssign := Trim(Copy(Line,lp,i-lp));
        if (Copy(Line,i,2) = '>=') or (Copy(Line,i,2) = '<=') then
        begin
          Rec.DLL := Copy(Line,i,2);
          Inc(i);
        end
        else
          Rec.DLL := Line[i];
        Inc(i);
        lp := i;
      end
      else if (Line[i] = '@') and not inStr and (Rec.Func = '') then
      begin
        Rec.DLL := Trim(Copy(Line,lp,i-lp));
        Rec.PartType := ptDLLFunc;
        hasAlfa := True;
        Inc(i);
        lp := i;
      end
      else if (Line[i] = '(') and not inStr then
      begin
        isStarted := True;
        inBracks := True;
        Rec.IsFunc := True;
        Rec.Func := Trim(Copy(Line,lp,i-lp));
        if not hasAlfa then Rec.Func := LowerCase(Rec.Func);
        Inc(i);
        lp := i;
      end
      else if (Line[i] = ',') and not inStr then
      begin
        AddParam(Copy(Line,lp,i-lp));
        Inc(i);
        lp := i;
      end
      else if (Line[i] = ')') and not inStr then
      begin
        inBracks := False;
        AddParam(Copy(Line,lp,i-lp));
        i := i + 1;
        lp := i;
      end
      else if (Copy(Line,i,2) = ' _') and not inStr then
      begin
        ReadLn(CFile,S);
        CurrLn := CurrLn + 1;
        Line := Copy(Line,1,Length(Line)-2) + S;
      end
      else if (Line[i] = ';') and not inStr then
      begin
        isEnded := True;
        if Rec.PartType = ptFuncLabel the
          Rec.Extra := LowerCase(Trim(Copy(Line,lp,i-lp)))
        else if (Pos('(',Line) = 0) and (Pos(')',Line) = 0) and not (Rec.PartType = ptIf) and not (Rec.PartType = ptWhile) then
        begin
          Rec.Func := Rec.Func + LowerCase(Trim(Copy(Line,lp,i-lp)));
          isStarted := True;
        end
        else
          Rec.Extra := Trim(Copy(Line,lp,i-lp));
        i := Length(Line) + 1;
      end
      else if (Line[i] = ':') and not inStr and not inBracks and not (Rec.PartType = ptFuncLabel) then
      begin
        isStarted := True;
        isEnded := True;
        Rec.PartType := ptLabel;
        Rec.Extra := Trim(Copy(Line,1,i-1));
        i := Length(Line) + 1;
      end
      else if (Copy(Line,i,2) = '//') and not inStr then
        i := Length(Line) + 1
      else Inc(i);
    end;
    if isStarted and isEnded then
    begin
      Rec.Params := p;
      Rec.ParamCount := pl;
      Rec.CurrFile := CurrFile;
      Rec.LineNum := CurrLn;
      Rec.Offset := 0;
      Rec.Done := False;
      Parts.Add(Rec);
    end
    else if not (Copy(Trim(Line),1,2) = '//') and not (Trim(Line) = '') then
      AddMessage(WrongSyntax);
  end;

begin
  CurrFile := Filename;
  CurrLn := 1;
  AssignFile(CFile,Filename);
  Reset(CFile);
  while not EOF(CFile) do
  begin
    ReadLn(CFile,S);
    ParseLine(S);
    CurrLn := CurrLn + 1;
  end;
  CloseFile(CFile);
end;

destructor TParser.Destroy;
begin
  Warnings.Free;
  Parts.Free;
  Errors.Free;
  inherited;
end;

end.