/Components/FastReport3/FastScript/fs_iinterpreter.pas

Large files files are truncated, but you can click here to view the full file

{******************************************}
{                                          }
{             FastScript v1.7              }
{               Main module                }
{                                          }
{ (c) 2003, 2004 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 = 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;
    FItems: TList;
    FIsRunning: Boolean;
    FLines: TStrings;
    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(Item: TObject);
    procedure AddCodeLine(const UnitName, APos: String);
    procedure Remove(Item: TObject);
    procedure RemoveItems(Owner: TObject);
    procedure Clear;
    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 Items[Index: Integer]: TfsCustomVariable read GetItem;
    property IsRunning: Boolean read FIsRunning;
    property Parent: TfsScript read FParent write FParent;
    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;
    FIsReadOnly: Boolean;
    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;
    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;
    property IsOptional: Boolean read FIsOptional;
    property IsVarParam: Boolean read FIsVarParam;
  end;

{ TfsProcVariable is a local internal procedure/function. Formal parameters
  are in Params, and statement to execute is in Prog: TfsScript }

  TfsProcVariable = class(TfsCustomVariable)
  private
    FExecuting: Boolean;
    FIsFunc: Boolean;
    FProgram: TfsScript;
  protected
    function GetValue: Variant; override;
  public
    constructor Create(const AName: String; ATyp: TfsVarType;
      const ATypeName: String; AParent: TfsScript; AIsFunc: Boolean = True);
    destructor Destroy; override;

    property Executing: Boolean read FExecuting;
    property IsFunc: Boolean read FIsFunc;
    property Prog: TfsScript read FProgram;
  end;

  TfsCustomExpression = class(TfsCustomVariable)
  end;

{ TfsCustomHelper is the generic class for the "helpers". Helper is
  a object that takes the data from the parent object and performs some
  actions. Helpers needed for properties, methods and arrays }

  TfsCustomHelper = class(TfsCustomVariable)
  private
    FParentRef: TfsCustomVariable;
    FParentValue: Variant;
    FProgram: TfsScript;
  public
    property ParentRef: TfsCustomVariable read FParentRef write FParentRef;
    property ParentValue: Variant read FParentValue write FParentValue;
    property Prog: TfsScript read FProgram write FProgram;
  end;

{ TfsArrayHelper performs access to array elements }

  TfsArrayHelper = class(TfsCustomHelper)
  protected
    procedure SetValue(const Value: Variant); override;
    function GetValue: Variant; override;
  public
    constructor Create(const AName: String; DimCount: Integer; Typ: TfsVarType;
      const TypeName: String);
  end;

{ TfsStringHelper performs access to string elements }

  TfsStringHelper = class(TfsCustomHelper)
  protected
    procedure SetValue(const Value: Variant); override;
    function GetValue: Variant; override;
  public
    constructor Create;
  end;

{ TfsPropertyHelper gets/sets the property value. Object instance is
  stored as Integer in the ParentValue property }

  TfsPropertyHelper = class(TfsCustomHelper)
  private
    FClassRef: TClass;
    FIsPublished: Boolean;
    FOnGetValue: TfsGetValueEvent;
    FOnSetValue: TfsSetValueEvent;
  protected
    procedure SetValue(const Value: Variant); override;
    function GetValue: Variant; override;
  public
    property IsPublished: Boolean read FIsPublished;
    property OnGetValue: TfsGetValueEvent read FOnGetValue write FOnGetValue;
    property OnSetValue: TfsSetValueEvent read FOnSetValue write FOnSetValue;
  end;

{ TfsMethodHelper gets/sets the method value. Object instance is
  stored as Integer in the ParentValue property. SetValue is called
  if the method represents the indexes property. }

  TfsMethodHelper = class(TfsCustomHelper)
  private
    FCategory: String;
    FClassRef: TClass;
    FDescription: String;
    FIndexMethod: Boolean;
    FOnCall: TfsCallMethodEvent;
    FSyntax: String;
  protected
    procedure SetValue(const Value: Variant); override;
    function GetValue: Variant; override;
  public
    constructor Create(const Syntax: String; CallEvent: TfsCallMethodEvent;
      Script: TfsScript);

    property Category: String read FCategory write FCategory;
    property Description: String read FDescription write FDescription;
    property IndexMethod: Boolean read FIndexMethod;
    property Syntax: String read FSyntax;
    property OnCall: TfsCallMethodEvent read FOnCall write FOnCall;
  end;

{ TfsComponentHelper gets the component inside an owner, e.g. Form1.Button1 }

  TfsComponentHelper = class(TfsCustomHelper)
  private
    FComponent: TComponent;
  protected
    function GetValue: Variant; override;
  public
    constructor Create(Component: TComponent);
  end;

{ Event helper maintains VCL events }

  TfsCustomEvent = class(TObject)
  private
    FHandler: TfsProcVariable;
    FInstance: TObject;
  protected
    procedure CallHandler(Params: array of const);
  public
    constructor Create(AObject: TObject; AHandler: TfsProcVariable); virtual;
    function GetMethod: Pointer; virtual; abstract;
    property Handler: TfsProcVariable read FHandler;
    property Instance: TObject read FInstance;
  end;

  TfsEventClass = class of TfsCustomEvent;

  TfsEventHelper = class(TfsCustomHelper)
  private
    FClassRef: TClass;
    FEvent: TfsEventClass;
  protected
    procedure SetValue(const Value: Variant); override;
    function GetValue: Variant; override;
  public
    constructor Create(const Name: String; AEvent: TfsEventClass);
  end;

{ TfsClassVariable holds information about external class. Call to
  AddXXX methods adds properties and methods items to the items list }

  TfsClassVariable = class(TfsCustomVariable)
  private
    FAncestor: String;
    FClassRef: TClass;
    FDefProperty: TfsCustomHelper;
    FMembers: TfsItemList;
    FProgram: TfsScript;
    procedure AddComponent(c: TComponent);
    procedure AddPublishedProperties(AClass: TClass);
    function GetMembers(Index: Integer): TfsCustomHelper;
    function GetMembersCount: Integer;
  protected
    function GetValue: Variant; override;
  public
    constructor Create(AClass: TClass; const Ancestor: String);
    destructor Destroy; override;

    { Adds a contructor. Example:
        AddConstructor('constructor Create(AOwner: TComponent)', MyCallEvent) }
    procedure AddConstructor(Syntax: String; CallEvent: TfsCallMethodEvent);
    { Adds a property. Example:
        AddProperty('Font', 'TFont', MyGetEvent, MySetEvent) }
    procedure AddProperty(const Name, Typ: String;
      GetEvent: TfsGetValueEvent; SetEvent: TfsSetValueEvent = nil);
    { Adds a default property. Example:
        AddDefaultProperty('Cell', 'Integer,Integer', 'String', MyCallEvent)
      will describe real property Cell[Index1, Index2: Integer]: String
      Note: in the CallEvent you'll get the MethodName parameter
      'CELL.GET' and 'CELL.SET', not 'CELL' }
    procedure AddDefaultProperty(const Name, Params, Typ: String;
      CallEvent: TfsCallMethodEvent; AReadOnly: Boolean = False);
    { Adds an indexed property. Example and behavior are the same as
      for AddDefaultProperty }
    procedure AddIndexProperty(const Name, Params, Typ: String;
      CallEvent: TfsCallMethodEvent; AReadOnly: Boolean = False);
    { Adds a method. Example:
        AddMethod('function IsVisible: Boolean', MyCallEvent) }
    procedure AddMethod(const Syntax: String; CallEvent: TfsCallMethodEvent);
    { Adds an event. Example:
        AddEvent('OnClick', TfsNotifyEvent) }
    procedure AddEvent(const Name: String; AEvent: TfsEventClass);
    function Find(const Name: String): TfsCustomHelper;

    property Ancestor: String read FAncestor;
    property ClassRef: TClass read FClassRef;
    property DefProperty: TfsCustomHelper read FDefProperty;
    property Members[Index: Integer]: TfsCustomHelper read GetMembers;
    property MembersCount: Integer read GetMembersCount;
  end;

{ TfsDesignator holds the parts of function/procedure/variable/method/property
  calls. Items are of type TfsDesignatorItem.
  For example, Table1.FieldByName('N').AsString[1] will be represented as
    items[0]: name 'Table1', no params
    items[1]: name 'FieldByName', 1 param: 'N'
    items[2]: name 'AsString', no params
    items[3]: name '[', 1 param: '1'
  Call to Value calculates and returns the designator value }

  TfsDesignatorKind = (dkOther, dkVariable, dkStringArray, dkArray);

  TfsDesignatorItem = class(TfsItemList)
  private
    FFlag: Boolean;          { needed for index methods }
    FRef: TfsCustomVariable;
    FSourcePos: String;
    function GetItem(Index: Integer): TfsCustomExpression;
  public
    property Items[Index: Integer]: TfsCustomExpression read GetItem; default;
    property Flag: Boolean read FFlag write FFlag;
    property Ref: TfsCustomVariable read FRef write FRef;
    property SourcePos: String read FSourcePos write FSourcePos;
  end;

  TfsDesignator = class(TfsCustomVariable)
  private
    FKind: TfsDesignatorKind;
    FProgram: TfsScript;
    FRef1: TfsCustomVariable;
    FRef2: TfsDesignatorItem;
    FLateBindingXmlSource: TfsXMLItem;
    procedure CheckLateBinding;
    function DoCalc(const AValue: Variant; Flag: Boolean): Variant;
    function GetItem(Index: Integer): TfsDesignatorItem;
  protected
    function GetValue: Variant; override;
    procedure SetValue(const Value: Variant); override;
  public
    constructor Create(AProgram: TfsScript);
    procedure Borrow(ADesignator: TfsDesignator);
    procedure Finalize;
    property Items[Index: Integer]: TfsDesignatorItem read GetItem; default;
    property Kind: TfsDesignatorKind read FKind;
    property LateBindingXmlSource: TfsXMLItem read FLateBindingXmlSource
      write FLateBindingXmlSource;
  end;

  TfsVariableDesignator = class(TfsDesignator)
  protected
    function GetValue: Variant; override;
    procedure SetValue(const Value: Variant); override;
  end;

  TfsStringDesignator = class(TfsDesignator)
  protected
    function GetValue: Variant; override;
    procedure SetValue(const Value: Variant); override;
  end;

  TfsArrayDesignator = class(TfsDesignator)
  protected
    function GetValue: Variant; override;
    procedure SetValue(const Value: Variant); override;
  end;

{ TfsSetExpression represents a set of values like ['_', '0'..'9'] }

  TfsSetExpression = class(TfsCustomVariable)
  private
    function GetItem(Index: Integer): TfsCustomExpression;
  protected
    function GetValue: Variant; override;
  public
    function Check(const Value: Variant): Boolean;
    property Items[Index: Integer]: TfsCustomExpression read GetItem;
  end;

{ TfsEventList maintains all event handlers attached to a VCL controls }

  TfsEventList = class(TfsItemList)
  public
    procedure FreeObjectEvents(Instance: TObject);
  end;


function fsGlobalUnit: TfsScript;
function fsEventList: TfsEventList;


implementation

//{$DEFINE Trial}

uses
  TypInfo, fs_isysrtti, fs_iexpression, fs_iparser, fs_iilparser,
  fs_itools, fs_iconst
{$IFDEF CLX}
, QForms, QDialogs, Types
{$ELSE}
  {$IFDEF NOFORMS}
, Windows, Messages
  {$ELSE}
, Windows, Forms, Dialogs
  {$ENDIF}
{$ENDIF};


var
  FGlobalUnit: TfsScript;
  FEventList: TfsEventList;
  FGlobalUnitDestroyed: Boolean = False;


{ TfsItemsList }

constructor TfsItemList.Create;
begin
  FItems := TList.Create;
end;

destructor TfsItemList.Destroy;
begin
  Clear;
  FItems.Free;
  inherited;
end;

procedure TfsItemList.Clear;
begin
  while FItems.Count > 0 do
  begin
    TObject(FItems[0]).Free;
    FItems.Delete(0);
  end;
end;

function TfsItemList.Count: Integer;
begin
  Result := FItems.Count;
end;

procedure TfsItemList.Add(Item: TObject);
begin
  FItems.Add(Item);
end;

procedure TfsItemList.Remove(Item: TObject);
begin
  FItems.Remove(Item);
end;


{ TfsCustomVariable }

constructor TfsCustomVariable.Create(const AName: String; ATyp: TfsVarType;
  const ATypeName: String);
begin
  inherited Create;
  FName := AName;
  FTyp := ATyp;
  FTypeName := ATypeName;
  FValue := Null;
  FNeedResult := True;
end;

function TfsCustomVariable.GetValue: Variant;
begin
  Result := FValue;
end;

procedure TfsCustomVariable.SetValue(const Value: Variant);
begin
  if not FIsReadOnly then
    FValue := Value;
end;

function TfsCustomVariable.GetParam(Index: Integer): TfsParamItem;
begin
  Result := FItems[Index];
end;

function TfsCustomVariable.GetPValue: PVariant;
begin
  Result := @FValue;
end;

function TfsCustomVariable.GetFullTypeName: String;
begin
  case FTyp of
    fvtInt: Result := 'Integer';
    fvtBool: Result := 'Boolean';
    fvtFloat: Result := 'Extended';
    fvtChar: Result := 'Char';
    fvtString: Result := 'String';
    fvtClass: Result := 'Class ' + FTypeName;
    fvtArray: Result := 'Array';
    fvtEnum: Result := FTypeName;
  else
    Result := 'Variant';
  end;
end;

function TfsCustomVariable.GetNumberOfRequiredParams: Integer;
var
  i: Integer;
begin
  Result := 0;
  for i := 0 to Count - 1 do
    if not Params[i].IsOptional then
      Inc(Result);
end;


{ TfsStringVariable }

function TfsStringVariable.GetValue: Variant;
begin
  Result := FStr;
end;

procedure TfsStringVariable.SetValue(const Value: Variant);
begin
  FStr := Value;
end;


{ TfsParamItem }

constructor TfsParamItem.Create(const AName: String; ATyp: TfsVarType;
  const ATypeName: String; AIsOptional, AIsVarParam: Boolean);
begin
  inherited Create(AName, ATyp, ATypeName);
  FIsOptional := AIsOptional;
  FIsVarParam := AIsVarParam;
  FDefValue := Null;
end;


{ TfsProcVariable }

constructor TfsProcVariable.Create(const AName: String; ATyp: TfsVarType;
  const ATypeName: String; AParent: TfsScript; AIsFunc: Boolean = True);
begin
  inherited Create(AName, ATyp, ATypeName);
  FIsReadOnly := True;
  FIsFunc := AIsFunc;
  FProgram := TfsScript.Create(nil);
  FProgram.Parent := AParent;
  if FIsFunc then
  begin
    FRefItem := TfsVariable.Create('Result', ATyp, ATypeName);
    FProgram.Add(FRefItem);
  end;
end;

destructor TfsProcVariable.Destroy;
var
  i: Integer;
begin
  { avoid destroying the param objects twice }
  for i := 0 to Count - 1 do
    FProgram.FItems.Remove(Params[i]);

  FProgram.Free;
  inherited;
end;

function TfsProcVariable.GetValue: Variant;
var
  Temp: Boolean;
  ParentProg, SaveProg: TfsScript;
begin
  Temp := FExecuting;
  FExecuting := True;

  ParentProg := FProgram;
  SaveProg := nil;
  while ParentProg <> nil do
    if Assigned(ParentProg.FOnRunLine) then
    begin
      SaveProg := ParentProg.FProgRunning;
      ParentProg.FProgRunning := FProgram;
      break;
    end
    else
      ParentProg := ParentProg.FParent;

  try
// avoid trial message
// same as FProgram.Execute
    with FProgram do
    begin
      FExitCalled := False;
      FTerminated := False;
      FIsRunning := True;
      try
        FStatement.Execute;
      finally
        FExitCalled := False;
        FTerminated := False;
        FIsRunning := False;
      end;
    end;
//

    if FIsFunc then
      Result := FRefItem.Value else
      Result := Null;
  finally
    if ParentProg <> nil then
      ParentProg.FProgRunning := SaveProg;
    FExecuting := Temp;
  end;
end;


{ TfsPropertyHelper }

function TfsPropertyHelper.GetValue: Variant;
var
  p: PPropInfo;
  Instance: TObject;
begin
  Result := Null;
  Instance := TObject(Integer(ParentValue));

  if FIsPublished then
  begin
    p := GetPropInfo(Instance.ClassInfo, Name);
    if p <> nil then
      case p.PropType^.Kind of
        tkInteger, tkSet, tkEnumeration, tkClass:
          Result := GetOrdProp(Instance, p);

        tkFloat:
          Result := GetFloatProp(Instance, p);

        tkString, tkLString, tkWString:
          Result := GetStrProp(Instance, p);

        tkChar, tkWChar:
          Result := Chr(GetOrdProp(Instance, p));

        tkVariant:
          Result := GetVariantProp(Instance, p);
      end;
  end
  else if Assigned(FOnGetValue) then
    Result := FOnGetValue(Instance, FClassRef, AnsiUpperCase(Name));

  if Typ = fvtBool then
    if Result = 0 then
      Result := False else
      Result := True;
end;

procedure TfsPropertyHelper.SetValue(const Value: Variant);
var
  p: PPropInfo;
  Instance: TObject;
  IntVal: Integer;
begin
  if IsReadOnly then Exit;
  Instance := TObject(Integer(ParentValue));

  if FIsPublished then
  begin
    p := GetPropInfo(Instance.ClassInfo, Name);
    if p <> nil then
      case p.PropType^.Kind of
        tkInteger, tkSet, tkEnumeration, tkClass:
        begin
          if Typ = fvtBool then
            if Value = True then
              IntVal := 1 else
              IntVal := 0
          else
            IntVal := Integer(Value);
          SetOrdProp(Instance, p, IntVal);
        end;

        tkFloat:
          SetFloatProp(Instance, p, Extended(Value));

        tkString, tkLString, tkWString:
          SetStrProp(Instance, p, String(Value));

        tkChar, tkWChar:
          SetOrdProp(Instance, p, Ord(String(Value)[1]));

        tkVariant:
          SetVariantProp(Instance, p, Value);
      end;
  end
  else if Assigned(FOnSetValue) then
    FOnSetValue(Instance, FClassRef, AnsiUpperCase(Name), Value);
end;


{ TfsMethodHelper }

constructor TfsMethodHelper.Create(const Syntax: String;
  CallEvent: TfsCallMethodEvent; Script: TfsScript);
var
  i: Integer;
  v: TfsCustomVariable;
begin
  v := ParseMethodSyntax(Syntax, Script);
  inherited Create(v.Name, v.Typ, v.TypeName);
  FOnCall := CallEvent;
  FIsReadOnly := True;
  FSyntax := Syntax;

  { copying params }
  for i := 0 to v.Count - 1 do
    Add(v.Params[i]);
  while v.Count > 0 do
    v.FItems.Delete(0);
  v.Free;
end;

function TfsMethodHelper.GetValue: Variant;
var
  v: Variant;
  i: Integer;
  s: String;
  Instance: TObject;
begin
  if Assigned(FOnCall) then
  begin
    v := VarArrayCreate([0, Count - 1], varVariant);
    for i := 0 to Count - 1 do
      v[i] := Params[i].Value;

    s := Name;
    if FIndexMethod then
      s := s + '.Get';

    Instance := nil;
    if ParentValue <> Null then
      Instance := TObject(Integer(ParentValue));

    Result := FOnCall(Instance, FClassRef, AnsiUpperCase(s), v);
    for i := 0 to Count - 1 do
      if Params[i].IsVarParam then
        Params[i].Value := v[i];
    v := Null;
  end
  else
    Result := 0;
end;

procedure TfsMethodHelper.SetValue(const Value: Variant);
var
  v: Variant;
  i: Integer;
begin
  if Assigned(FOnCall) and FIndexMethod then
  begin
    v := VarArrayCreate([0, Count], varVariant);
    for i := 0 to Count - 1 do
      v[i] := Params[i].Value;
    v[Count] := Value;

    FOnCall(TObject(Integer(ParentValue)), FClassRef, AnsiUpperCase(Name + '.Set'), v);
    v := Null;
  end;
end;


{ TfsComponentHelper }

constructor TfsComponentHelper.Create(Component: TComponent);
begin
  inherited Create(Component.Name, fvtClass, Component.ClassName);
  FComponent := Component;
end;

function TfsComponentHelper.GetValue: Variant;
begin
  Result := Integer(FComponent);
end;


{ TfsEventHelper }

constructor TfsEventHelper.Create(const Name: String; AEvent: TfsEventClass);
begin
  inherited Create(Name, fvtString, '');
  FEvent := AEvent;
end;

function TfsEventHelper.GetValue: Variant;
begin
  Result := '';
end;

procedure TfsEventHelper.SetValue(const Value: Variant);
var
  Instance: TPersistent;
  v: TfsCustomVariable;
  e: TfsCustomEvent;
  p: PPropInfo;
  m: TMethod;
begin
  Instance := TPersistent(Integer(ParentValue));
  if VarToStr(Value) = '0' then
  begin
    m.Code := nil;
    m.Data := nil;
  end
  else
  begin
    v := FProgram.Find(Value);
    if (v = nil) or not (v is TfsProcVariable) then
      raise Exception.Create(SEventError);

    e := TfsCustomEvent(FEvent.NewInstance);
    e.Create(Instance, TfsProcVariable(v));
    fsEventList.Add(e);
    m.Code := e.GetMethod;
    m.Data := e;
  end;

  p := GetPropInfo(Instance.ClassInfo, Name);
  SetMethodProp(Instance, p, m);
end;


{ TfsClassVariable }

constructor TfsClassVariable.Create(AClass: TClass; const Ancestor: String);
begin
  inherited Create(AClass.ClassName, fvtClass, AClass.ClassName);
  FMembers := TfsItemList.Create;
  FAncestor := Ancestor;
  FClassRef := AClass;

  AddPublishedProperties(AClass);
  Add(TfsParamItem.Create('', fvtVariant, '', True, False));
end;

destructor TfsClassVariable.Destroy;
begin
  FMembers.Free;
  inherited;
end;

function TfsClassVariable.GetMembers(Index: Integer): TfsCustomHelper;
begin
  Result := FMembers.FItems[Index];
end;

function TfsClassVariable.GetMembersCount: Integer;
begin
  Result := FMembers.Count;
end;

procedure TfsClassVariable.AddConstructor(Syntax: String; CallEvent: TfsCallMethodEvent);
var
  i: Integer;
begin
  i := Pos(' ', Syntax);
  Delete(Syntax, 1, i - 1);
  Syntax := 'function' + Syntax + ': ' + 'Constructor';
  AddMethod(Syntax, CallEvent);
end;

procedure TfsClassVariable.AddMethod(const Syntax: String; CallEvent: TfsCallMethodEvent);
var
  m: TfsMethodHelper;
begin
  m := TfsMethodHelper.Create(Syntax, CallEvent, FProgram);
  m.FClassRef := FClassRef;
  FMembers.Add(m);
end;

procedure TfsClassVariable.AddEvent(const Name: String; AEvent: TfsEventClass);
var
  e: TfsEventHelper;
begin
  e := TfsEventHelper.Create(Name, AEvent);
  e.FClassRef := FClassRef;
  FMembers.Add(e);
end;

procedure TfsClassVariable.AddProperty(const Name, Typ: String;
  GetEvent: TfsGetValueEvent; SetEvent: TfsSetValueEvent);
var
  p: TfsPropertyHelper;
begin
  p := TfsPropertyHelper.Create(Name, StrToVarType(Typ, FProgram), Typ);
  p.FClassRef := FClassRef;
  p.FOnGetValue := GetEvent;
  p.FOnSetValue := SetEvent;
  p.IsReadOnly := not Assigned(SetEvent);
  FMembers.Add(p);
end;

procedure TfsClassVariable.AddDefaultProperty(const Name, Params, Typ: String;
  CallEvent: TfsCallMethodEvent; AReadOnly: Boolean = False);
begin
  AddIndexProperty(Name, Params, Typ, CallEvent, AReadOnly);
  FDefProperty := Members[FMembers.Count - 1];
end;

procedure TfsClassVariable.AddIndexProperty(const Name, Params,
  Typ: String; CallEvent: TfsCallMethodEvent; AReadOnly: Boolean = False);
var
  i: Integer;
  sl: TStringList;
  s: String;
begin
  sl := TStringList.Create;
  sl.CommaText := Params;

  s := '';
  for i := 0 to sl.Count - 1 do
    s := s + 'p' + IntToStr(i) + ': ' + sl[i] + '; ';

  SetLength(s, Length(s) - 2);
  try
    AddMethod('function ' + Name + '(' + s + '): ' + Typ, CallEvent);
    with TfsMethodHelper(Members[FMembers.Count - 1]) do
    begin
      IsReadOnly := AReadOnly;
      FIndexMethod := True;
    end;
  finally
    sl.Free;
  end;
end;

procedure TfsClassVariable.AddComponent(c: TComponent);
begin
  FMembers.Add(TfsComponentHelper.Create(c));
end;

procedure TfsClassVariable.AddPublishedProperties(AClass: TClass);
var
  TypeInfo: PTypeInfo;
  PropCount: Integer;
  PropList: PPropList;
  i: Integer;
  cl: String;
  t: TfsVarType;
  FClass: TClass;
  p: TfsPropertyHelper;
begin
  TypeInfo := AClass.ClassInfo;
  if TypeInfo = nil then Exit;

  PropCount := GetPropList(TypeInfo, tkProperties, nil);
  GetMem(PropList, PropCount * SizeOf(PPropInfo));
  GetPropList(TypeInfo, tkProperties, PropList);

  try
    for i := 0 to PropCount - 1 do
    begin
      t := fvtInt;
      cl := '';

      case PropList[i].PropType^.Kind of
        tkInteger:
          t := fvtInt;
        tkSet:
          begin
            t := fvtEnum;
            cl := PropList[i].PropType^.Name;
          end;
        tkEnumeration:
          begin
            t := fvtEnum;
            cl := PropList[i].PropType^.Name;
            if CompareText(cl, 'Boolean') = 0 then
              t := fvtBool;
          end;
        tkFloat:
          t := fvtFloat;
        tkChar, tkWChar:
          t := fvtChar;
        tkString, tkLString, tkWString:
          t := fvtString;
        tkVariant:
          t := fvtVariant;
        tkClass:
          begin
            t := fvtClass;
            FClass := GetTypeData(PropList[i].PropType^).ClassType;
            cl := FClass.ClassName;
          end;
      end;

      p := TfsPropertyHelper.Create(PropList[i].Name, t, cl);
      p.FClassRef := FClassRef;
      p.FIsPublished := True;
      FMembers.Add(p);
    end;

  finally
    FreeMem(PropList, PropCount * SizeOf(PPropInfo));
  end;
end;

function TfsClassVariable.Find(const Name: String): TfsCustomHelper;
var
  cl: TfsClassVariable;

  function DoFind(const Name: String): TfsCustomHelper;
  var
    i: Integer;
  begin
    Result := nil;
    for i := 0 to FMembers.Count - 1 do
      if CompareText(Name, Members[i].Name) = 0 then
      begin
        Result := Members[i];
        Exit;
      end;
  end;

begin
  Result := DoFind(Name);
  if Result = nil then
  begin
    cl := FProgram.FindClass(FAncestor);
    if cl <> nil then
      Result := cl.Find(Name);
  end;
end;

function TfsClassVariable.GetValue: Variant;
begin
  if Params[0].Value = Null then
    Result := Integer(FClassRef.NewInstance) else        { constructor call }
    Result := Params[0].Value;                           { typecast }
  Params[0].Value := Null;
end;


{ TfsDesignatorItem }

function TfsDesignatorItem.GetItem(Index: Integer): TfsCustomExpression;
begin
  Result := FItems[Index];
end;


{ TfsDesignator }

constructor TfsDesignator.Create(AProgram: TfsScript);
begin
  inherited Create('', fvtInt, '');
  FProgram := AProgram;
end;

procedure TfsDesignator.Borrow(ADesignator: TfsDesignator);
var
  SaveItems: TList;
begin
  SaveItems := FItems;
  FItems := ADesignator.FItems;
  ADesignator.FItems := SaveItems;
  FKind := ADesignator.FKind;
  FRef1 := ADesignator.FRef1;
  FRef2 := ADesignator.FRef2;
  FTyp := ADesignator.Typ;
  FTypeName := ADesignator.TypeName;
  FIsReadOnly := ADesignator.IsReadOnly;
  RefItem := ADesignator.RefItem;
end;

procedure TfsDesignator.Finalize;
var
  Item: TfsDesignatorItem;
begin
  Item := Items[Count - 1];
  FTyp := Item.Ref.Typ;
  FTypeName := Item.Ref.TypeName;
  if FTyp = fvtConstructor then
  begin
    FTyp := fvtClass;
    FTypeName := Items[Count - 2].Ref.TypeName;
  end;

  FIsReadOnly := Item.Ref.IsReadOnly;

  { speed optimization for access to single variable, string element or array }
  if (Count = 1) and (Items[0].Ref is TfsVariable) then
  begin
    RefItem := Items[0].Ref;
    FKind := dkVariable;
  end
  else if (Count = 2) and (Items[0].Ref is TfsStringVariable) then
  begin
    RefItem := Items[0].Ref;
    FRef1 := Items[1][0];
    FKind := dkStringArray;
  end
  else if (Count = 2) and (Items[0].Ref is TfsVariable) and (Items[0].Ref.Typ = fvtArray) then
  begin
    RefItem := Items[0].Ref;
    FRef1 := RefItem.RefItem;
    FRef2 := Items[1];
    FKind := dkArray;
  end
  else
    FKind := dkOther;
end;

function TfsDesignator.GetItem(Index: Integer): TfsDesignatorItem;
begin
  Result := FItems[Index];
end;

function TfsDesignator.DoCalc(const AValue: Variant; Flag: Boolean): Variant;
var
  i, j: Integer;
  Item: TfsCustomVariable;
  Val: Variant;
  Ref: TfsCustomVariable;
  Temp, Temp1: array of Variant;

  { copy local variables to Temp }
  procedure SaveLocalVariables(Item: TfsCustomVariable);
  var
    i: Integer;
  begin
    with TfsProcVariable(Item) do
    begin
      SetLength(Temp, Prog.Count);

      for i := 0 to Prog.Count - 1 do
        if (Prog.Items[i] is TfsVariable) or (Prog.Items[i] is TfsParamItem) then
          Temp[i] := Prog.Items[i].Value;
    end;
  end;

  { restore local variables from Temp}
  procedure RestoreLocalVariables(Item: TfsCustomVariable);
  var
    i: Integer;
  begin
    with TfsProcVariable(Item) do
      for i := 0 to Prog.Count - 1 do
        if (Prog.Items[i] is TfsVariable) or (Prog.Items[i] is TfsParamItem) then
          Prog.Items[i].Value := Temp[i];

    Temp := nil;
  end;

begin
  Ref := nil;
  Val := Null;

  for i := 0 to Count - 1 do
  begin
    Item := Items[i].Ref;

    if Item is TfsDesignator then { it is true for "WITH" statements }
    begin
      Ref := Item;
      Val := Item.Value;
      continue;
    end;

    { we're trying to call the local procedure that is already executing -
      i.e. we have a recursion }
    if (Item is TfsProcVariable) and TfsProcVariable(Item).Executing then
      SaveLocalVariables(Item);

    if Item.Count > 0 then
    begin
      SetLength(Temp1, Item.Count);
      try
        { calculate params and copy param values to the temp1 array }
        for j := 0 to Item.Count - 1 do
          Temp1[j] := Items[i][j].Value;
        { copy calculated values to the item params }
        for j := 0 to Item.Count - 1 do
          Item.Params[j].Value := Temp1[j];
      finally
        Temp1 := nil;
      end;
    end;

    { copy value and var reference to the helper object }
    if Item is TfsCustomHelper then
    begin
      TfsCustomHelper(Item).ParentRef := Ref;
      TfsCustomHelper(Item).ParentValue := Val;
      TfsCustomHelper(Item).Prog := FProgram;
    end;

    Ref := Item;
    { assign a value to the last designator node if called from SetValue }
    if Flag and (i = Count - 1) then
      Item.Value := AValue
    else
    begin
      Item.NeedResult := (i <> Count - 1) or NeedResult;
      Val := Item.Value;
    end;

    { copy back var params }
    for j := 0 to Item.Count - 1 do
      if Item.Params[j].IsVarParam then
        Items[i][j].Value := Item.Params[j].Value;

    { restore proc variables if it was called from itself }
    if (Item is TfsProcVariable) and TfsProcVariable(Item).Executing then
      RestoreLocalVariables(Item);
  end;

  Result := Val;
end;

procedure TfsDesignator.CheckLateBinding;
var
  NewDesignator: TfsDesignator;
  Parser: TfsILParser;
begin
  if FLateBindingXMLSource <> nil then
  begin
    Parser := TfsILParser.Create(FProgram);
    try
      NewDesignator := Parser.DoDesignator(FLateBindingXMLSource, FProgram);
      Borrow(NewDesignator);
      NewDesignator.Free;
    finally
      Parser.Free;
      FLateBindingXMLSource.Free;
      FLateBindingXMLSource := nil;
    end;
  end;
end;

function TfsDesignator.GetValue: Variant;
begin
  CheckLateBinding;
  Result := DoCalc(Null, False);
end;

procedure TfsDesignator.SetValue(const Value: Variant);
begin
  CheckLateBinding;
  DoCalc(Value, True);
end;


{ TfsVariableDesignator }

function TfsVariableDesignator.GetValue: Variant;
begin
  Result := RefItem.Value;
end;

procedure TfsVariableDesignator.SetValue(const Value: Variant);
begin
  RefItem.Value := Value;
end;


{ TfsStringDesignator }

function TfsStringDesignator.GetValue: Variant;
begin
  Result := TfsStringVariable(RefItem).FStr[Integer(FRef1.Value)];
end;

procedure TfsStringDesignator.SetValue(const Value: Variant);
begin
  TfsStringVariable(RefItem).FStr[Integer(FRef1.Value)] := VarToStr(Value)[1];
end;


{ TfsArrayDesignator }

function TfsArrayDesignator.GetValue: Variant;
var
  i: Integer;
begin
  TfsCustomHelper(FRef1).ParentRef := RefItem;
  for i := 0 to FRef2.Count - 1 do
    FRef1.Params[i].Value := FRef2[i].Value;
  Result := FRef1.Value;
end;

procedure TfsArrayDesignator.SetValue(const Value: Variant);
var
  i: Integer;
begin
  TfsCustomHelper(FRef1).ParentRef := RefItem;
  for i := 0 to FRef2.Count - 1 do
    FRef1.Params[i].Value := FRef2[i].Value;
  FRef1.Value := Value;
end;


{ TfsSetExpression }

function TfsSetExpression.Check(const Value: Variant): Boolean;
var
  i: Integer;
  Expr: TfsCustomExpression;
begin
  Result := False;

 (* TfsSetExpression encapsulates the set like [1,2,3..10]
    In the example above we'll have the following Items:
    TfsExpression {1}
    TfsExpression {2}
    TfsExpression {3}
    nil (indicates the range )
    TfsExpression {10} *)

  i := 0;
  while i < Count do
  begin
    Expr := Items[i];

    if (i < Count - 1) and (Items[i + 1] = nil) then { subrange }
    begin
      Result := (Value >= Expr.Value) and (Value <= Items[i + 2].Value);
      Inc(i, 2);
    end
    else
      Result := Value = Expr.Value;

    if Result then break;
    Inc(i);
  end;
end;

function TfsSetExpression.GetItem(Index: Integer): TfsCustomExpression;
begin
  Result := FItems[Index];
end;

function TfsSetExpression.GetValue: Variant;
var
  i: Integer;
begin
  Result := VarArrayCreate([0, Count - 1], varVariant);

  for i := 0 to Count - 1 do
    if Items[i] = nil then
      Result[i] := 0 else
      Result[i] := Items[i].Value;
end;


{ TfsScript }

constructor TfsScript.Create(AOwner: TComponent);
begin
  inherited;
  FItems := TList.Create;
  FLines := TStringList.Create;
  FStatement := TfsStatement.Create(Self, '', '');
  FSyntaxType := 'PascalScript';
  FUnitLines := TStringList.Create;
  Add(TfsStringHelper.Create);
  Add(TfsArrayHelper.Create('__ArrayHelper', -1, fvtVariant, ''));
end;

destructor TfsScript.Destroy;
begin
  inherited;
  Clear;
  FItems.Free;
  FLines.Free;
  FStatement.Free;
  FUnitLines.Free;
end;

procedure TfsScript.Add(Item: TObject);
begin
  FItems.Add(Item);
end;

function TfsScript.Count: Integer;
begin
  Result := FItems.Count;
end;

procedure TfsScript.Remove(Item: TObject);
begin
  FItems.Remove(Item);
end;

procedure TfsScript.Clear;
begin
  while FItems.Count > 0 do
  begin
    TObject(FItems[0]).Free;
    FItems.Delete(0);
  end;
  FStatement.Clear;
  FUnitLines.Clear;
end;

procedure TfsScript.RemoveItems(Owner: TObject);
var
  i: Integer;
begin
  for i := Count - 1 downto 0 do
    if Items[i].AddedBy = Owner then
    begin
      Items[i].Free;
      Remove(Items[i]);
    end;
end;

function TfsScript.GetItem(Index: Integer): TfsCustomVariable;
begin
  Result := FItems[Index];
end;

function TfsScript.Find(const Name: String): TfsCustomVariable;
begin
  Result := FindLocal(Name);

  { trying to find the identifier in all parent programs }
  if (Result = nil) and (FParent <> nil) then
    Result := FParent.Find(Name);
end;

function TfsScript.FindLocal(const Name: String): TfsCustomVariable;
var
  i: Integer;
begin
  Result := nil;
  for i := 0 to Count - 1 do
    if AnsiCompareText(Name, TfsCustomVariable(FItems[i]).Name) = 0 then
    begin
      Result := FItems[i];
      Exit;
    end;
end;

function TfsScript.Compile: Boolean;
var
  p: TfsILParser;
begin
  Result := False;
  FErrorMsg := '';

  p := TfsILParser.Create(Self);
  try
    p.SelectLanguage(FSyntaxType);
    if p.MakeILScript(FLines.Text) then
      p.ParseILScript;
  finally
    p.Free;
  end;

  if FErrorMsg = '' then
  begin
    Result := True;
    FErrorPos := '';
  end
end;

procedure TfsScript.Execute;
begin
{$IFDEF Trial}
  ShowMessage('Unregistered version of FastScript.');
{$ENDIF}
  FExitCalled := False;
  FTerminated := False;
  FIsRunning := True;
  try
    …