fs_iinterpreter.pas

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

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

unit fs_iinterpreter;

interface

{$I fs.inc}

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


type
  TfsStatement = class;
  TfsDesignator = class;
  TfsCustomVariable = class;
  TfsClassVariable = class;
  TfsScript = class;

{ List of supported types. Actually all values are variants; types needed
  only to know what kind of operations can be implemented to the variable }

  TfsVarType = (fvtInt, fvtBool, fvtFloat, fvtChar, fvtString, fvtClass,
    fvtArray, fvtVariant, fvtEnum, fvtConstructor);

  TfsTypeRec = packed record
    Typ: TfsVarType;
    TypeName: String[32];
  end;

{ Events for get/set non-published property values and call methods }

  TfsGetValueEvent = function(Instance: TObject; ClassType: TClass;
    const PropName: String): Variant of object;
  TfsSetValueEvent = procedure(Instance: TObject; ClassType: TClass;
    const PropName: String; Value: Variant) of object;
  TfsCallMethodEvent = function(Instance: TObject; ClassType: TClass;
    const MethodName: String; var Params: Variant): Variant of object;
  TfsRunLineEvent = procedure(Sender: TfsScript;
    const UnitName, SourcePos: String) of object;
  TfsGetUnitEvent = procedure(Sender: TfsScript;
    const UnitName: String; var UnitText: String) of object;

{ List of objects. Unlike TList, Destructor frees all objects in the list }

  TfsItemList = class(TObject)
  protected
    FItems: TList;
  public
    constructor Create;
    destructor Destroy; override;
    procedure Clear; virtual;
    function Count: Integer;
    procedure Add(Item: TObject);
    procedure Remove(Item: TObject);
  end;


{ TfsScript represents the main script. It holds the list of local variables,
  constants, procedures in the Items. Entry point is the Statement.

  There is one global object fsGlobalUnit: TfsScript that holds all information
  about external classes, global variables, methods and constants. To use
  such globals, pass fsGlobalUnit to the TfsScript.Create.
  If you want, you can add classes/variables/methods to the TfsScript - they
  will be local for it and not visible in other programs.

  To execute a program, compile it first by calling Compile method. If error
  occurs, the ErrorMsg will contain the error message and ErrorPos will point
  to an error position in the source text. For example:

    if not Prg.Compile then
    begin
      ErrorLabel.Caption := Prg.ErrorMsg;
      Memo1.SetFocus;
      Memo1.Perform(EM_SETSEL, Prg.ErrorPos - 1, Prg.ErrorPos - 1);
      Memo1.Perform(EM_SCROLLCARET, 0, 0);
    end;

  If no errors occured, call Execute method to execute the program }

  TfsScript = class(TComponent)
  private
    FAddedBy: TObject;
    FBreakCalled: Boolean;
    FContinueCalled: Boolean;
    FExitCalled: Boolean;
    FErrorMsg: String;
    FErrorPos: String;
    FErrorUnit: String;
    FExtendedCharset: Boolean;
    FItems: TStringList;
    FIsRunning: Boolean;
    FLines: TStrings;
    FMacros: TStrings;
    FMainProg: Boolean;
    FOnGetILUnit: TfsGetUnitEvent;
    FOnGetUnit: TfsGetUnitEvent;
    FOnRunLine: TfsRunLineEvent;
    FParent: TfsScript;
    FProgRunning: TfsScript;
    FStatement: TfsStatement;
    FSyntaxType: String;
    FTerminated: Boolean;
    FUnitLines: TStringList;
    function GetItem(Index: Integer): TfsCustomVariable;
    procedure RunLine(const UnitName, Index: String);
    function GetVariables(Index: String): Variant;
    procedure SetVariables(Index: String; const Value: Variant);
    procedure SetLines(const Value: TStrings);
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Add(const Name: String; Item: TObject);
    procedure AddCodeLine(const UnitName, APos: String);
    procedure Remove(Item: TObject);
    procedure RemoveItems(Owner: TObject);
    procedure Clear;
    procedure ClearItems(Owner: TObject);
    function Count: Integer;

    { Adds a class. Example:
        with AddClass(TComponent, 'TPersistent') do
        begin
          ... add properties and methods ...
        end }
    function AddClass(AClass: TClass; const Ancestor: String): TfsClassVariable;
    { Adds a constant. Example:
        AddConst('pi', 'Double', 3.14159) }
    procedure AddConst(const Name, Typ: String; const Value: Variant);
    { Adds an enumeration constant. Example:
        AddEnum('TFontPitch', 'fpDefault, fpFixed, fpVariable')
      all constants gets type fvtEnum and values 0,1,2,3.. }
    procedure AddEnum(const Typ, Names: String);
    { Adds an set constant. Example:
        AddEnumSet('TFontStyles', 'fsBold, fsItalic, fsUnderline')
      all constants gets type fvtEnum and values 1,2,4,8,.. }
    procedure AddEnumSet(const Typ, Names: String);
    { Adds a form or datamodule with all its child components }
    procedure AddComponent(Form: TComponent);
    procedure AddForm(Form: TComponent);
    { Adds a method. Syntax is the same as for TfsClassVariable.AddMethod }
    procedure AddMethod(const Syntax: String; CallEvent: TfsCallMethodEvent;
      const Category: String = ''; const Description: String = '');
    { Adds an external object. Example:
        AddObject('Memo1', Memo1) }
    procedure AddObject(const Name: String; Obj: TObject);
    { Adds a variable. Example:
        AddVariable('n', 'Variant', 0) }
    procedure AddVariable(const Name, Typ: String; const Value: Variant);
    { Adds a type. Example:
        AddType('TDateTime', fvtFloat) }
    procedure AddType(const TypeName: String; ParentType: TfsVarType);
    { Calls internal procedure or function. Example:
        val := CallFunction('ScriptFunc1', VarArrayOf([2003, 3])) }
    function CallFunction(const Name: String; const Params: Variant): Variant;
    function CallFunction1(const Name: String; var Params: Variant): Variant;

    { Compiles the source code. Example:
        Lines.Text := 'begin i := 0 end.';
        SyntaxType := 'PascalScript';
        if Compile then ... }
    function Compile: Boolean;
    { Executes compiled code }
    procedure Execute;
    { Same as if Compile then Execute. Returns False if compile failed }
    function Run: Boolean;
    { terminates the script }
    procedure Terminate;
    { Evaluates an expression (useful for debugging purposes). Example:
        val := Evaluate('i+1'); }
    function Evaluate(const Expression: String): Variant;
    { checks whether is the line is executable }
    function IsExecutableLine(LineN: Integer; const UnitName: String = ''): Boolean;

    { Generates intermediate language. You can save it and compile later
      by SetILCode method }
    function GetILCode(Stream: TStream): Boolean;
    { Compiles intermediate language }
    function SetILCode(Stream: TStream): Boolean;

    function Find(const Name: String): TfsCustomVariable;
    function FindClass(const Name: String): TfsClassVariable;
    function FindLocal(const Name: String): TfsCustomVariable;

    property AddedBy: TObject read FAddedBy write FAddedBy;
    property ErrorMsg: String read FErrorMsg write FErrorMsg;
    property ErrorPos: String read FErrorPos write FErrorPos;
    property ErrorUnit: String read FErrorUnit write FErrorUnit;
    property ExtendedCharset: Boolean read FExtendedCharset write FExtendedCharset;
    property Items[Index: Integer]: TfsCustomVariable read GetItem;
    property IsRunning: Boolean read FIsRunning;
    property Macros: TStrings read FMacros;
    property MainProg: Boolean read FMainProg write FMainProg;
    property Parent: TfsScript read FParent write FParent;
    property ProgRunning: TfsScript read FProgRunning;
    property Statement: TfsStatement read FStatement;
    property Variables[Index: String]: Variant read GetVariables write SetVariables;
  published
    { the source code }
    property Lines: TStrings read FLines write SetLines;
    { the language name }
    property SyntaxType: String read FSyntaxType write FSyntaxType;
    property OnGetILUnit: TfsGetUnitEvent read FOnGetILUnit write FOnGetILUnit;
    property OnGetUnit: TfsGetUnitEvent read FOnGetUnit write FOnGetUnit;
    property OnRunLine: TfsRunLineEvent read FOnRunLine write FOnRunLine;
  end;


  TfsCustomExpression = class;
  TfsSetExpression = class;

{ Statements }

  TfsStatement = class(TfsItemList)
  private
    FProgram: TfsScript;
    FSourcePos: String;
    FUnitName: String;
    function GetItem(Index: Integer): TfsStatement;
    procedure RunLine;
  public
    constructor Create(AProgram: TfsScript; const UnitName, SourcePos: String); virtual;
    procedure Execute; virtual;
    property Items[Index: Integer]: TfsStatement read GetItem;
  end;

  TfsAssignmentStmt = class(TfsStatement)
  private
    FDesignator: TfsDesignator;
    FExpression: TfsCustomExpression;
    FVar: TfsCustomVariable;
    FExpr: TfsCustomVariable;
  public
    destructor Destroy; override;
    procedure Execute; override;
    procedure Optimize;
    property Designator: TfsDesignator read FDesignator write FDesignator;
    property Expression: TfsCustomExpression read FExpression write FExpression;
  end;

  TfsAssignPlusStmt = class(TfsAssignmentStmt)
  public
    procedure Execute; override;
  end;

  TfsAssignMinusStmt = class(TfsAssignmentStmt)
  public
    procedure Execute; override;
  end;

  TfsAssignMulStmt = class(TfsAssignmentStmt)
  public
    procedure Execute; override;
  end;

  TfsAssignDivStmt = class(TfsAssignmentStmt)
  public
    procedure Execute; override;
  end;

  TfsCallStmt = class(TfsStatement)
  private
    FDesignator: TfsDesignator;
    FModificator: String;
  public
    destructor Destroy; override;
    procedure Execute; override;
    property Designator: TfsDesignator read FDesignator write FDesignator;
    property Modificator: String read FModificator write FModificator;
  end;

  TfsIfStmt = class(TfsStatement)
  private
    FCondition: TfsCustomExpression;
    FElseStmt: TfsStatement;
  public
    constructor Create(AProgram: TfsScript; const UnitName, SourcePos: String); override;
    destructor Destroy; override;
    procedure Execute; override;
    property Condition: TfsCustomExpression read FCondition write FCondition;
    property ElseStmt: TfsStatement read FElseStmt write FElseStmt;
  end;

  TfsCaseSelector = class(TfsStatement)
  private
    FSetExpression: TfsSetExpression;
  public
    destructor Destroy; override;
    function Check(const Value: Variant): Boolean;
    property SetExpression: TfsSetExpression read FSetExpression write FSetExpression;
  end;

  TfsCaseStmt = class(TfsStatement)
  private
    FCondition: TfsCustomExpression;
    FElseStmt: TfsStatement;
  public
    constructor Create(AProgram: TfsScript; const UnitName, SourcePos: String); override;
    destructor Destroy; override;
    procedure Execute; override;
    property Condition: TfsCustomExpression read FCondition write FCondition;
    property ElseStmt: TfsStatement read FElseStmt write FElseStmt;
  end;

  TfsRepeatStmt = class(TfsStatement)
  private
    FCondition: TfsCustomExpression;
    FInverseCondition: Boolean;
  public
    destructor Destroy; override;
    procedure Execute; override;
    property Condition: TfsCustomExpression read FCondition write FCondition;
    property InverseCondition: Boolean read FInverseCondition write FInverseCondition;
  end;

  TfsWhileStmt = class(TfsStatement)
  private
    FCondition: TfsCustomExpression;
  public
    destructor Destroy; override;
    procedure Execute; override;
    property Condition: TfsCustomExpression read FCondition write FCondition;
  end;

  TfsForStmt = class(TfsStatement)
  private
    FBeginValue: TfsCustomExpression;
    FDown: Boolean;
    FEndValue: TfsCustomExpression;
    FVariable: TfsCustomVariable;
  public
    destructor Destroy; override;
    procedure Execute; override;
    property BeginValue: TfsCustomExpression read FBeginValue write FBeginValue;
    property Down: Boolean read FDown write FDown;
    property EndValue: TfsCustomExpression read FEndValue write FEndValue;
    property Variable: TfsCustomVariable read FVariable write FVariable;
  end;

  TfsVbForStmt = class(TfsStatement)
  private
    FBeginValue: TfsCustomExpression;
    FEndValue: TfsCustomExpression;
    FStep: TfsCustomExpression;
    FVariable: TfsCustomVariable;
  public
    destructor Destroy; override;
    procedure Execute; override;
    property BeginValue: TfsCustomExpression read FBeginValue write FBeginValue;
    property EndValue: TfsCustomExpression read FEndValue write FEndValue;
    property Step: TfsCustomExpression read FStep write FStep;
    property Variable: TfsCustomVariable read FVariable write FVariable;
  end;

  TfsCppForStmt = class(TfsStatement)
  private
    FFirstStmt: TfsStatement;
    FExpression: TfsCustomExpression;
    FSecondStmt: TfsStatement;
  public
    constructor Create(AProgram: TfsScript; const UnitName, SourcePos: String); override;
    destructor Destroy; override;
    procedure Execute; override;
    property FirstStmt: TfsStatement read FFirstStmt write FFirstStmt;
    property Expression: TfsCustomExpression read FExpression write FExpression;
    property SecondStmt: TfsStatement read FSecondStmt write FSecondStmt;
  end;

  TfsTryStmt = class(TfsStatement)
  private
    FIsExcept: Boolean;
    FExceptStmt: TfsStatement;
  public
    constructor Create(AProgram: TfsScript; const UnitName, SourcePos: String); override;
    destructor Destroy; override;
    procedure Execute; override;
    property IsExcept: Boolean read FIsExcept write FIsExcept;
    property ExceptStmt: TfsStatement read FExceptStmt write FExceptStmt;
  end;

  TfsBreakStmt = class(TfsStatement)
  public
    procedure Execute; override;
  end;

  TfsContinueStmt = class(TfsStatement)
  public
    procedure Execute; override;
  end;

  TfsExitStmt = class(TfsStatement)
  public
    procedure Execute; override;
  end;

  TfsWithStmt = class(TfsStatement)
  private
    FDesignator: TfsDesignator;
    FVariable: TfsCustomVariable;
  public
    destructor Destroy; override;
    procedure Execute; override;
    property Designator: TfsDesignator read FDesignator write FDesignator;
    property Variable: TfsCustomVariable read FVariable write FVariable;
  end;

{ TfsCustomVariable is the generic class for variables, constants, arrays,
  properties, methods and procedures/functions }

  TfsParamItem = class;

  TfsCustomVariable = class(TfsItemList)
  private
    FAddedBy: TObject;
    FIsMacro: Boolean;
    FIsReadOnly: Boolean;
    FLocked: Boolean;
    FLockedBy: TObject;
    FName: String;
    FNeedResult: Boolean;
    FRefItem: TfsCustomVariable;
    FSourcePos: String;
    FTyp: TfsVarType;
    FTypeName: String;
    FValue: Variant;
    function GetParam(Index: Integer): TfsParamItem;
    function GetPValue: PVariant;
  protected
    procedure SetValue(const Value: Variant); virtual;
    function GetValue: Variant; virtual;
  public
    constructor Create(const AName: String; ATyp: TfsVarType;
      const ATypeName: String);
    function GetFullTypeName: String;
    function GetNumberOfRequiredParams: Integer;

    property AddedBy: TObject read FAddedBy write FAddedBy;
    property IsMacro: Boolean read FIsMacro write FIsMacro;
    property IsReadOnly: Boolean read FIsReadOnly write FIsReadOnly;
    property Name: String read FName;
    property NeedResult: Boolean read FNeedResult write FNeedResult;
    property Params[Index: Integer]: TfsParamItem read GetParam; default;
    property PValue: PVariant read GetPValue;
    property RefItem: TfsCustomVariable read FRefItem write FRefItem;
    property SourcePos: String read FSourcePos write FSourcePos;
    property Typ: TfsVarType read FTyp write FTyp;
    property TypeName: String read FTypeName write FTypeName;
    property Value: Variant read GetValue write SetValue;
  end;

{ TfsVariable represents constant or variable }

  TfsVariable = class(TfsCustomVariable)
  end;

  TfsTypeVariable = class(TfsCustomVariable)
  end;

  TfsStringVariable = class(TfsVariable)
  private
    FStr: String;
  protected
    procedure SetValue(const Value: Variant); override;
    function GetValue: Variant; override;
  end;

{ TfsParamItem describes one parameter of procedure/function/method call }

  TfsParamItem = class(TfsCustomVariable)
  private
    FDefValue: Variant;
    FIsOptional: Boolean;
    FIsVarParam: Boolean;
  public
    constructor Create(const AName: String; ATyp: TfsVarType;
      const ATypeName: String; AIsOptional, AIsVarParam: Boolean);
    property DefValue: Variant read FDefValue write FDefValue;