fs_iilparser.pas

报表源码 FastReport 3 is new generation of the report generators components. It consists of report engin

{******************************************}
{                                          }
{             FastScript v1.8              }
{       Intermediate Language parser       }
{                                          }
{  (c) 2003-2005 by Alexander Tzyganenko,  }
{             Fast Reports Inc             }
{                                          }
{******************************************}

unit fs_iilparser;

interface

{$i fs.inc}

uses
  SysUtils, Classes, fs_iinterpreter, fs_iparser, fs_iexpression, fs_xml
{$IFDEF Delphi6}
, Variants
{$ENDIF};


type
  TfsEmitOp = (emNone, emCreate, emFree);

{ TfsILParser performs the syntax analyze of source code. Source code
  can be on ANY language. Grammars are stored in the XML file and
  can be easily changed to support any structured language. Currently
  supported languages are Pascal, C++, Basic and Java subsets.

  The result of the analyze (function MakeScript) is the output XML script
  (called Intermediate Language). This output processed by the ParseILScript
  method. This method creates the program structure (defined in the
  fs_Interpreter unit) and fills it by the data }

  TfsILParser = class(TObject)
  private
    FErrorPos: String;
    FGrammar: TfsXMLDocument;
    FILScript: TfsXMLDocument;
    FLangName: String;
    FNeedDeclareVars: Boolean;
    FParser: TfsParser;
    FProgram: TfsScript;
    FProgRoot: TfsXMLItem;
    FRoot: TfsXMLItem;
    FUnitName: String;
    FUsesList: TStrings;
    FWithList: TStringList;
    function PropPos(xi: TfsXMLItem): String;
    procedure ErrorPos(xi: TfsXMLItem);
    procedure CheckIdent(Prog: TfsScript; const Name: String);
    function FindClass(const TypeName: String): TfsClassVariable;
    procedure CheckTypeCompatibility(Var1, Var2: TfsCustomVariable);
    function FindVar(Prog: TfsScript; const Name: String): TfsCustomVariable;
    function FindType(s: String): TfsVarType;
    function CreateVar(xi: TfsXMLItem; Prog: TfsScript; const Name: String;
      Statement: TfsStatement = nil; CreateParam: Boolean = False;
      IsVarParam: Boolean = False): TfsCustomVariable;
    function DoSet(xi: TfsXMLItem; Prog: TfsScript): TfsSetExpression;
    function DoExpression(xi: TfsXMLItem; Prog: TfsScript): TfsExpression;
    procedure DoUses(xi: TfsXMLItem; Prog: TfsScript);
    procedure DoVar(xi: TfsXMLItem; Prog: TfsScript; Statement: TfsStatement);
    procedure DoConst(xi: TfsXMLItem; Prog: TfsScript);
    procedure DoParameters(xi: TfsXMLItem; v: TfsProcVariable);
    procedure DoProc1(xi: TfsXMLItem; Prog: TfsScript);
    procedure DoProc2(xi: TfsXMLItem; Prog: TfsScript);
    procedure DoFunc1(xi: TfsXMLItem; Prog: TfsScript);
    procedure DoFunc2(xi: TfsXMLItem; Prog: TfsScript);
    procedure DoAssign(xi: TfsXMLItem; Prog: TfsScript; Statement: TfsStatement);
    procedure DoCall(xi: TfsXMLItem; Prog: TfsScript; Statement: TfsStatement);
    procedure DoIf(xi: TfsXMLItem; Prog: TfsScript; Statement: TfsStatement);
    procedure DoFor(xi: TfsXMLItem; Prog: TfsScript; Statement: TfsStatement);
    procedure DoVbFor(xi: TfsXMLItem; Prog: TfsScript; Statement: TfsStatement);
    procedure DoCppFor(xi: TfsXMLItem; Prog: TfsScript; Statement: TfsStatement);
    procedure DoWhile(xi: TfsXMLItem; Prog: TfsScript; Statement: TfsStatement);
    procedure DoRepeat(xi: TfsXMLItem; Prog: TfsScript; Statement: TfsStatement);
    procedure DoCase(xi: TfsXMLItem; Prog: TfsScript; Statement: TfsStatement);
    procedure DoTry(xi: TfsXMLItem; Prog: TfsScript; Statement: TfsStatement);
    procedure DoBreak(xi: TfsXMLItem; Prog: TfsScript; Statement: TfsStatement);
    procedure DoContinue(xi: TfsXMLItem; Prog: TfsScript; Statement: TfsStatement);
    procedure DoExit(xi: TfsXMLItem; Prog: TfsScript; Statement: TfsStatement);
    procedure DoReturn(xi: TfsXMLItem; Prog: TfsScript; Statement: TfsStatement);
    procedure DoWith(xi: TfsXMLItem; Prog: TfsScript; Statement: TfsStatement);
    procedure DoDelete(xi: TfsXMLItem; Prog: TfsScript; Statement: TfsStatement);
    procedure DoCompoundStmt(xi: TfsXMLItem; Prog: TfsScript; Statement: TfsStatement);
    procedure DoStmt(xi: TfsXMLItem; Prog: TfsScript; Statement: TfsStatement);
    procedure DoProgram(xi: TfsXMLItem; Prog: TfsScript);
  public
    constructor Create(AProgram: TfsScript);
    destructor Destroy; override;

    procedure SelectLanguage(const LangName: String);
    { convert the input script to the Intermediate Language }
    function MakeILScript(const Text: String): Boolean;
    { parse IL }
    procedure ParseILScript;
    { this method is needed here to implement late-binding }
    function DoDesignator(xi: TfsXMLItem; Prog: TfsScript;
      EmitOp: TfsEmitOp = emNone): TfsDesignator;
    property ILScript: TfsXMLDocument read FILScript;
  end;


implementation

uses fs_itools, fs_iconst
{$IFDEF CLX}
, Types
{$ELSE}
, Windows
{$ENDIF}
{$IFDEF OLE}
, fs_idisp
{$ENDIF};


{ TfsILParser }

constructor TfsILParser.Create(AProgram: TfsScript);
begin
  FNeedDeclareVars := True;
  FProgram := AProgram;
  FGrammar := TfsXMLDocument.Create;
  FILScript := TfsXMLDocument.Create;
  FParser := TfsParser.Create;
  FUsesList := TStringList.Create;
  FWithList := TStringList.Create;
end;

destructor TfsILParser.Destroy;
begin
  FGrammar.Free;
  FILScript.Free;
  FParser.Free;
  FUsesList.Free;
  FWithList.Free;
  inherited;
end;

procedure TfsILParser.SelectLanguage(const LangName: String);
var
  i: Integer;
  Name, PropText: String;
  xi: TfsXMLItem;
  ParserRoot: TfsXMLItem;
  ss: TStringStream;
begin
  FParser.Clear;
  FLangName := LangName;
  ss := TStringStream.Create(fsGetLanguage(LangName));
  try
    FGrammar.LoadFromStream(ss);
  finally
    ss.Free;
  end;

  FRoot := FGrammar.Root;
  ParserRoot := FRoot.FindItem('parser');

  xi := ParserRoot.FindItem('keywords');
  for i := 0 to xi.Count - 1 do
    FParser.Keywords.Add(xi[i].Name);

  for i := 0 to ParserRoot.Count - 1 do
  begin
    Name := LowerCase(ParserRoot[i].Name);
    PropText := ParserRoot[i].Prop['text'];
    if Name = 'identchars' then
      FParser.ConstructCharset(PropText)
    else if Name = 'commentline1' then
      FParser.CommentLine1 := PropText
    else if Name = 'commentline2' then
      FParser.CommentLine2 := PropText
    else if Name = 'commentblock1' then
      FParser.CommentBlock1 := PropText
    else if Name = 'commentblock2' then
      FParser.CommentBlock2 := PropText
    else if Name = 'stringquotes' then
      FParser.StringQuotes := PropText
    else if Name = 'hexsequence' then
      FParser.HexSequence := PropText
    else if Name = 'declarevars' then
    begin
      if PropText = '0' then
        FNeedDeclareVars := False;
    end
    else if Name = 'skipeol' then
    begin
      if PropText = '0' then
        FParser.SkipEOL := False;
    end
    else if Name = 'skipchar' then
      FParser.SkipChar := PropText;
  end;

  if FProgram.ExtendedCharset then
    for i := 128 to 255 do
      FParser.IdentifierCharset := FParser.IdentifierCharset + [Chr(i)];
end;

function TfsILParser.MakeILScript(const Text: String): Boolean;
var
  FList: TStrings;
  FStream: TStream;
  FErrorMsg: String;
  FErrorPos: String;
  FTermError: Boolean;
  i: Integer;

  function Run(xi: TfsXMLItem): Boolean;
  var
    i, j, ParsPos, ParsPos1, LoopPos, ListPos: Integer;
    s, NodeName, Token, PropText, PropAdd, PropAddText, PropNode: String;
    Completed, TopLevelNode, Flag: Boolean;

    procedure DoInclude(const Name: String);
    var
      sl: TStringList;
      p: TfsILParser;
      ss: TStringStream;
      s: String;
    begin
      if FUsesList.IndexOf(Name) <> -1 then
        Exit;
      FUsesList.Add(Name);

      sl := TStringList.Create;
      try
        if Assigned(FProgram.OnGetUnit) then
        begin
          s := '';
          FProgram.OnGetUnit(FProgram, Name, s);
          sl.Text := s;
        end
        else
          sl.LoadFromFile(Name);

        p := TfsILParser.Create(FProgram);
        p.FUnitName := Name;
        ss := TStringStream.Create('');
        try
          s := '';
          if sl.Count > 0 then
          begin
            p.SelectLanguage(FLangName);
            p.FUsesList.Assign(FUsesList);
            if p.MakeILScript(sl.Text) then
            begin
              FUsesList.Assign(p.FUsesList);
              p.ILScript.SaveToStream(ss);
              s := ss.DataString;
              Delete(s, 1, Pos('?>', s) + 1);
            end
            else
            begin
              FErrorMsg := FProgram.ErrorMsg;
              FProgram.ErrorUnit := Name;
            end;
          end;

          FList.Insert(ListPos, '</uses>');
          FList.Insert(ListPos, s);
          FList.Insert(ListPos, '<uses' + ' unit="' + Name + '">');
          Inc(ListPos, 3);
        finally
          p.Free;
          ss.Free;
        end;
      finally
        sl.Free;
      end;
    end;

    procedure CheckPropNode(Flag: Boolean);
    var
      i, ParsPos1: Integer;
      s: String;
    begin
      if CompareText(PropNode, 'uses') = 0 then
      begin
        while FList.Count > ListPos do
        begin
          s := FList[FList.Count - 1];
          i := Pos('text="', s);
          Delete(s, 1, i + 5);
          i := Pos('" ', s);
          Delete(s, i, 255);
          DoInclude(Copy(s, 2, Length(s) - 2));
          FList.Delete(FList.Count - 1);
        end;
      end
      else if PropNode <> '' then
        if Flag then
        begin
          ParsPos1 := FParser.Position;
          FParser.Position := ParsPos;
          FParser.SkipSpaces;

          s := '<' + PropNode + ' pos="' + FParser.GetXYPosition + '"';
          FParser.Position := ParsPos1;

          if PropNode = 'expr' then
            s := s + ' pos1="' + FParser.GetXYPosition + '"';
          s := s + '>';

          FList.Insert(ListPos, s);
          FList.Add('</' + PropNode + '>');
        end
        else
        begin
          while FList.Count > ListPos do
            FList.Delete(FList.Count - 1);
        end;
    end;

    procedure AddError(xi: TfsXMLItem);
    var
      PropErr: String;
      xi1: TfsXMLItem;
    begin
      PropErr := xi.Prop['err'];
      if (PropErr <> '') and (FErrorMsg = '') then
      begin
        xi1 := FRoot.FindItem('parser');
        xi1 := xi1.FindItem('errors');
        FErrorMsg := xi1.FindItem(PropErr).Prop['text'];
        FParser.Position := ParsPos;
        FParser.SkipSpaces;
        FErrorPos := FParser.GetXYPosition;
        FTermError := xi.Prop['term'] = '1';
      end;
    end;

  begin
    Result := True;
    ParsPos := FParser.Position;
    ListPos := FList.Count;

    NodeName := AnsiLowerCase(xi.Name);
    PropText := AnsiLowerCase(xi.Prop['text']);
    PropNode := LowerCase(xi.Prop['node']);
    TopLevelNode := xi.Parent = FRoot;

    Completed := False;
    Flag := False;
    Token := '';

    if TopLevelNode then
      Completed := True
    else if NodeName = 'char' then
    begin
      if xi.Prop['skip'] <> '0' then
        FParser.SkipSpaces;
      Token := FParser.GetChar;
      Flag := True;
    end
    else if NodeName = 'keyword' then
    begin
      Token := FParser.GetWord;
      Flag := True;
    end
    else if NodeName = 'ident' then
    begin
      Token := FParser.GetIdent;
      Flag := True;
    end
    else if NodeName = 'number' then
    begin
      Token := FParser.GetNumber;
      Flag := True;
    end
    else if NodeName = 'string' then
    begin
      Token := FParser.GetString;
      Flag := True;
    end
    else if NodeName = 'frstring' then
    begin
      Token := FParser.GetFRString;
      s := FParser.GetXYPosition;
      FList.Add('<dsgn pos="' + s + '">');
      FList.Add('<node text="Get" pos="' + s + '"/>');
      FList.Add('<expr pos="' + s + '">');
      FList.Add('<string text="''' + StrToXML(Token) + '''" pos="' + s + '"/>');
      FList.Add('</expr>');
      FList.Add('</dsgn>');
      Flag := True;
    end
    else if NodeName = 'eol' then
      Completed := FParser.GetEOL
    else if NodeName = 'sequence' then
      Completed := True
    else if (NodeName = 'switch') or (NodeName = 'optionalswitch') then
    begin
      Completed := True;

      for i := 0 to xi.Count - 1 do
      begin
        Completed := Run(xi[i]);
        if Completed then
          break;
      end;

      if not Completed then
        if NodeName <> 'optionalswitch' then
        begin
          Result := False;
          AddError(xi);
        end;
      Exit;
    end
    else if (NodeName = 'loop') or (NodeName = 'optionalloop') then
    begin
      j := 0;
      repeat
        Inc(j);
        Flag := False;
        LoopPos := FParser.Position;

        for i := 0 to xi.Count - 1 do
        begin
          Result := Run(xi[i]);
          if not Result then
          begin
            Flag := True;
            break;
          end;
        end;

        { try loop delimiter }
        ParsPos1 := FParser.Position;
        if Result and (PropText <> '') then
        begin
          FParser.SkipSpaces;
          if FParser.GetChar <> PropText then
          begin
            FParser.Position := ParsPos1;
            Flag := True;
          end;
        end;

        { avoid infinity loop }
        if FParser.Position = LoopPos then
          Flag := True;
      until Flag;

      { at least one loop was succesful }
      if j > 1 then
      begin
        { special case - now implemented only in "case" statement }
        if (xi.Prop['skip'] = '1') or FTermError then
          FErrorMsg := '';
        FParser.Position := ParsPos1;
        Result := True;
      end;

      if NodeName = 'optionalloop' then
      begin
        if not Result then
          FParser.Position := ParsPos;
        Result := True;
      end;
      Exit;
    end
    else if NodeName = 'optional' then
    begin
      for i := 0 to xi.Count - 1 do
        if not Run(xi[i]) then
        begin
          FParser.Position := ParsPos;