fs_iinterpreter.pas

这个是功能强大的报表软件

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

unit fs_iinterpreter;

interface

{$I fs.inc}

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

, SyncObjs;


type
  TfsStatement = class;
  TfsDesignator = class;
  TfsCustomVariable = class;
  TfsClassVariable = class;
  TfsProcVariable = class;
  TfsMethodHelper = class;
  TfsPropertyHelper = 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 = {$IFDEF Delphi12}{$ELSE}packed{$ENDIF} record
    Typ: TfsVarType;
{$IFDEF Delphi12}
    TypeName: String;
{$ELSE}
    TypeName: String[32];
{$ENDIF}
  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;

  TfsGetValueNewEvent = function(Instance: TObject; ClassType: TClass;
    const PropName: String; Caler: TfsPropertyHelper): Variant of object;
  TfsSetValueNewEvent = procedure(Instance: TObject; ClassType: TClass;
    const PropName: String; Value: Variant; Caller: TfsPropertyHelper) of object;

  TfsCallMethodNewEvent = function(Instance: TObject; ClassType: TClass;
    const MethodName: String; Caller: TfsMethodHelper): 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;
  TfsGetVariableValueEvent = function(VarName: String;
    VarTyp: TfsVarType; OldValue: Variant): Variant of object;

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

  TfsItemList = class(TObject)
  protected
    FItems: TList;
  protected
    procedure Clear; virtual;
  public
    constructor Create;
    destructor Destroy; override;
    procedure Add(Item: TObject);
    function Count: Integer;
    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;
    FOnGetVarValue: TfsGetVariableValueEvent;
    FParent: TfsScript;
    FProgRunning: TfsScript;
    FRTTIAdded: Boolean;
    FStatement: TfsStatement;
    FSyntaxType: String;
    FTerminated: Boolean;
    FUnitLines: TStringList;
    FIncludePath: TStrings;
    FUseClassLateBinding: Boolean;
    FEvaluteRiseError: Boolean;
    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 AddRTTI;
    procedure Remove(Item: TObject);
    procedure RemoveItems(Owner: TObject);
    procedure Clear;
    procedure ClearItems(Owner: TObject);
    procedure ClearRTTI;
    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; dynamic;
    { Adds a constant. Example:
        AddConst('pi', 'Double', 3.14159) }
    procedure AddConst(const Name, Typ: String; const Value: Variant); dynamic;
    { 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); dynamic;
    { 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); dynamic;
    { Adds a form or datamodule with all its child components }
    procedure AddComponent(Form: TComponent); dynamic;
    procedure AddForm(Form: TComponent); dynamic;
    { Adds a method. Syntax is the same as for TfsClassVariable.AddMethod }
    procedure AddMethod(const Syntax: String; CallEvent: TfsCallMethodNewEvent;
      const Category: String = ''; const Description: String = ''); overload; dynamic;
    procedure AddMethod(const Syntax: String; CallEvent: TfsCallMethodEvent;
      const Category: String = ''; const Description: String = ''); overload; dynamic;
    { Adds an external object. Example:
        AddObject('Memo1', Memo1) }
    procedure AddObject(const Name: String; Obj: TObject); dynamic;
    { Adds a variable. Example:
        AddVariable('n', 'Variant', 0) }
    procedure AddVariable(const Name, Typ: String; const Value: Variant); dynamic;
    { Adds a type. Example:
        AddType('TDateTime', fvtFloat) }
    procedure AddType(const TypeName: String; ParentType: TfsVarType); dynamic;
    { 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;
    function CallFunction2(const Func: TfsProcVariable; const 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;
    property IncludePath: TStrings read FIncludePath;
    property UseClassLateBinding: Boolean read FUseClassLateBinding write FUseClassLateBinding;
    property EvaluteRiseError: Boolean read FEvaluteRiseError;
  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;
    property OnGetVarValue: TfsGetVariableValueEvent read FOnGetVarValue write FOnGetVarValue;
  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;