FastReport_FMX_2.8.12/FastScript/fs_iinterpreter.pas

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

//VCL uses section
{$IFNDEF FMX}
unit fs_iinterpreter;

interface

{$I fs.inc}

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

, SyncObjs
{$IFDEF Delphi16}
  , System.Types
{$ENDIF};
//FMX uses section
{$ELSE}
interface

{$I fs.inc}

uses
  System.SysUtils, System.Classes, FMX.fs_xml
, System.Variants
, System.SyncObjs, System.Types;
{$ENDIF}


type
  TfsStatement = class;
  TfsDesignator = class;
  TfsCustomVariable = class;
  TfsClassVariable = class;
  TfsProcVariable = class;
  TfsMethodHelper = class;
  TfsPropertyHelper = class;
  TfsScript = class;
  TfsDesignatorItem = 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, fvtInt64);
{$IFDEF DELPHI16}
  frxInteger = NativeInt;
{$ELSE}
  {$IFDEF FPC}
    frxInteger = PtrInt;
  {$ELSE}
    frxInteger = Integer;
  {$ENDIF}
{$ENDIF}

  TfsTypeRec = {$IFDEF Delphi12}{$ELSE}packed{$ENDIF} record
    Typ: TfsVarType;
{$IFDEF Delphi12}
    TypeName: String;
{$ELSE}
    TypeName: String[64];
{$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 }

{$i frxPlatformsAttribute.inc}

  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;
    FClearLocalVars: Boolean;
    FLastSourcePos : String;
    FProgName : String;
    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);
    function GetProgName: String;
    procedure SetProgName(const Value: String);

  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; sGlobal: Boolean = false): Variant;
    function CallFunction1(const Name: String; var Params: Variant; sGlobal: Boolean = false): 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 ClearLocalVars: Boolean read FClearLocalVars write FClearLocalVars;
    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 ProgName: String read GetProgName write SetProgName;
    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;
    FIsMacro: Boolean;
    FIsReadOnly: Boolean;
    FName: String;
    FNeedResult: Boolean;
    FRefItem: TfsCustomVariable;
    FSourcePos: String;
    FSourceUnit: String;
    FTyp: TfsVarType;
    FTypeName: String;
    FUppercaseName: String;
    FValue: Variant;
    FOnGetVarValue: TfsGetVariableValueEvent;
    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 SourceUnit: String read FSourceUnit write FSourceUnit;
    property Typ: TfsVarType read FTyp write FTyp;
    property TypeName: String read FTypeName write FTypeName;
    property Value: Variant read GetValue write SetValue;
    property OnGetVarValue: TfsGetVariableValueEvent read FOnGetVarValue write FOnGetVarValue;
  end;

{ TfsVariable represents constant or variable }

  TfsVariable = class(TfsCustomVariable)
  protected
    procedure SetValue(const Value: Variant); override;
    function GetValue: Variant; override;
  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 }

  TfsLocalVariablesHelper = class(TObject)
  protected
    FValue: Variant;
    FVariableLink :TfsCustomVariable;
  end;


  TfsProcVariable = class(TfsCustomVariable)
  private
    FExecuting: Boolean;
    FIsFunc: Boolean;
    FProgram: TfsScript;
    FVarsStack: TList;
  protected
    function GetValue: Variant; override;
  public
    constructor Create(const AName: String; ATyp: TfsVarType;
      const ATypeName: String; AParent: TfsScript; AIsFunc: Boolean = True);
    destructor Destroy; override;
    function SaveLocalVariables: Integer;
    procedure RestoreLocalVariables(StackIndex: Integer; bSkipVarParams: Boolean = False; dItem: TfsDesignatorItem = nil);
    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);
    destructor Destroy; override;
  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;
    FOnGetValueNew: TfsGetValueNewEvent;
    FOnSetValueNew: TfsSetValueNewEvent;
  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;
    property OnGetValueNew: TfsGetValueNewEvent read FOnGetValueNew write FOnGetValueNew;
    property OnSetValueNew: TfsSetValueNewEvent read FOnSetValueNew write FOnSetValueNew;
  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;
    FOnCallNew: TfsCallMethodNewEvent;
    FSetValue: Variant;
    FSyntax: String;
    FVarArray: Variant;
    function GetVParam(Index: Integer): Variant;
    procedure SetVParam(Index: Integer; const Value: Variant);
  protected
    procedure SetValue(const Value: Variant); override;
    function GetValue: Variant; override;
  public
    constructor Create(const Syntax: String; Script: TfsScript);
    destructor Destroy; override;

    property Category: String read FCategory write FCategory;
    property Description: String read FDescription write FDescription;
    property IndexMethod: Boolean read FIndexMethod;
    property Params[Index: Integer]: Variant read GetVParam write SetVParam; default;
    property Syntax: String read FSyntax;
    property OnCall: TfsCallMethodEvent read FOnCall write FOnCall;
    property OnCallNew: TfsCallMethodNewEvent read FOnCallNew write FOnCallNew;
  end;

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

  TfsComponentHelper = class(TfsCustomHelper)
  protected
    function GetValue: Variant; override;
    procedure SetValue(const Value: Variant); override;
  public
    constructor Create(const Name: String; const ClassName: String);
  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 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: TfsCallMethodNewEvent); overload;
    procedure AddConstructor(Syntax: String; CallEvent: TfsCallMethodEvent); overload;
    function AddComponent(c: TComponent): TfsComponentHelper ;
    { Adds a property. Example:
        AddProperty('Font', 'TFont', MyGetEvent, MySetEvent) }
    procedure AddProperty(const Name, Typ: String;
      GetEvent: TfsGetValueEvent; SetEvent: TfsSetValueEvent = nil);
    procedure AddPropertyEx(const Name, Typ: String;
      GetEvent: TfsGetValueNewEvent; SetEvent: TfsSetValueNewEvent = 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: TfsCallMethodNewEvent; AReadOnly: Boolean = False); overload;
    procedure AddDefaultProperty(const Name, Params, Typ: String;
      CallEvent: TfsCallMethodEvent; AReadOnly: Boolean = False); overload;
    { Adds an indexed property. Example and behavior are the same as
      for AddDefaultProperty }
    procedure AddIndexProperty(const Name, Params, Typ: String;
      CallEvent: TfsCallMethodNewEvent; AReadOnly: Boolean = False); overload;
    procedure AddIndexProperty(const Name, Params, Typ: String;
      CallEvent: TfsCallMethodEvent; AReadOnly: Boolean = False); overload;
    { Adds a method. Example:
        AddMethod('function IsVisible: Boolean', MyCallEvent) }
    procedure AddMethod(const Syntax: String; CallEvent: TfsCallMethodNewEvent); overload;
    procedure AddMethod(const Syntax: String; CallEvent: TfsCallMethodEvent); overload;
    { Adds an event. Example:
        AddEvent('OnClick', TfsNotifyEvent) }
    procedure AddEvent(const Name: String; AEvent: TfsEventClass);
    function Find(const Name: String; IncludeComponentHelper: Boolean = True): 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;
    FMainProg: TfsScript;
    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);
    destructor Destroy; override;
    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;

  TfsRTTIModule = class(TObject)
  private
    FScript: TfsScript;
  public
    constructor Create(AScript: TfsScript); virtual;
    property Script: TfsScript read FScript;
  end;


function fsGlobalUnit: TfsScript;
function fsIsGlobalUnitExist: Boolean;
function fsRTTIModules: TList;


implementation
//VCL uses section
{$IFNDEF FMX}
uses
  TypInfo, fs_isysrtti, fs_iexpression, fs_iparser, fs_iilparser,
  fs_itools, fs_iconst
{$IFDEF DELPHI16}
  , Vcl.Controls
{$ENDIF}
{$IFDEF CLX}
, QForms, QDialogs, Types
{$ELSE}
  {$IFDEF FPC}
    {$IFDEF NOFORMS}
      // nothing
    {$ELSE}
      , Forms, Dialogs
    {$ENDIF}
  {$ELSE}
    , Windows
    {$IFDEF NOFORMS}
      , Messages
    {$ELSE}
      , Forms, Dialogs
    {$ENDIF}
  {$ENDIF}
{$ENDIF};
//FMX uses section
{$ELSE}
uses
  System.TypInfo, FMX.fs_isysrtti, FMX.fs_iexpression, FMX.fs_iparser, FMX.fs_iilparser,
  FMX.fs_itools, FMX.fs_iconst, FMX.Types
    {$IFDEF NOFORMS}
      , Windows, Messages
    {$ELSE}
      , FMX.Forms, FMX.Dialogs
    {$ENDIF};
{$ENDIF}

var
  FGlobalUnit: TfsScript = nil;
  FGlobalUnitDestroyed: Boolean = False;
  FRTTIModules: TList = nil;
  FRTTIModulesDestroyed: 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;
  FUppercaseName := AnsiUppercase(FName);
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';
    fvtInt64: Result := 'Int64';
    fvtBool: Result := 'Boolean';
    fvtFloat: Result := 'Extended';
    fvtChar: Result := 'Char';
    fvtString: Result := 'String';
    fvtClass: Result := 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;
  if Assigned(FOnGetVarValue) then
  begin
    Result := FOnGetVarValue(FName, FTyp, FStr);
    if Result = null then Result := FStr;
  end;
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;
  FVarsStack := TList.Create;
  FIsFunc := AIsFunc;
  FProgram := TfsScript.Create(nil);
  FProgram.Parent := AParent;
  if FProgram.Parent <> nil then
    FProgram.UseClassLateBinding := FProgram.Parent.UseClassLateBinding;
  if FIsFunc then
  begin
    FRefItem := TfsVariable.Create('Result', ATyp, ATypeName);
    FProgram.Add('Result', 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.Delete(FProgram.FItems.IndexOfObject(Params[i]));

  FProgram.Free;
  FVarsStack.Free;
  inherited;
end;

function TfsProcVariable.GetValue: Variant;
var
  Temp: Boolean;
  ParentProg, SaveProg: TfsScript;
  i: Integer;
begin
  Temp := FExecuting;
  FExecuting := True;
  if FIsFunc then
    FRefItem.Value := Unassigned;

  ParentProg := FProgram;
  SaveProg := nil;
  while ParentProg <> nil do
    if ParentProg.FMainProg 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;
      FProgName := Self.FName;
      try
        FStatement.Execute;
      finally
        FExitCalled := False;
        FTerminated := False;
        FIsRunning := False;
        FProgName := '';
      end;
    end;
//

    if FIsFunc then
      Result := FRefItem.Value else
      Result := Null;
  finally
    if ParentProg <> nil then
      ParentProg.FProgRunning := SaveProg;
    FExecuting := Temp;
    if (ParentProg <> nil) and ParentProg.FClearLocalVars then    
      for i := 0 to Prog.Count - 1 do
        if (Prog.Items[i] is TfsVariable) and
          (CompareText('Result', Prog.Items[i].Name) <> 0)
{$IFDEF DELPHI6}
          and not VarIsClear(Prog.Items[i].Value)
{$ENDIF}
          then
          case TfsVariable(Prog.Items[i]).Typ of
            fvtString:
              TfsVariable(Prog.Items[i]).Value := '';
            fvtInt, fvtFloat, fvtChar:
              TfsVariable(Prog.Items[i]).Value := 0;
            fvtVariant:
              TfsVariable(Prog.Items[i]).Value := Null;
          end;
  end;
end;

function TfsProcVariable.SaveLocalVariables: Integer;
var
  i: Integer;
  LocalVars: TList;
  StackItem: TfsLocalVariablesHelper;
begin
  LocalVars := TList.Create;
  FVarsStack.Add(LocalVars);
  Result := FVarsStack.Count - 1;
  for i := 0 to Prog.Count - 1 do
    if (Prog.Items[i] is TfsVariable) or (Prog.Items[i] is TfsParamItem) then
    begin
      StackItem := TfsLocalVariablesHelper.Create;
      StackItem.FValue := Prog.Items[i].Value;
      StackItem.FVariableLink := Prog.Items[i];
      LocalVars.Add(StackItem);
    end;
end;

procedure TfsProcVariable.RestoreLocalVariables(StackIndex: Integer; bSkipVarParams: Boolean; dItem: TfsDesignatorItem);
var
  i: Integer;
  LocalVars: TList;
  StackItem: TfsLocalVariablesHelper;
  bIsVar: Boolean;
  Temp1: array of Variant;
begin
  if (FVarsStack.Count < StackIndex) or (StackIndex < 0) then Exit;
  LocalVars := TList(FVarsStack[StackIndex]);
  SetLength(Temp1, Count);
  try
    { save var parameters value, need when pass same variable as VAR parameter }
    if Assigned(dItem) then    
      for i := 0 to Count - 1 do
        if Params[i].IsVarParam then
          Temp1[i] := Params[i].Value;
    for i := 0 to LocalVars.Count - 1 do
    begin
      StackItem := TfsLocalVariablesHelper(LocalVars[i]);
      bIsVar := TfsParamItem(StackItem.FVariableLink).FIsVarParam;
      if not (bSkipVarParams and (StackItem.FVariableLink is TfsParamItem) and bIsVar) then
        StackItem.FVariableLink.Value := StackItem.FValue;
      StackItem.Free;
    end;      
    if Assigned(dItem) then
      for i := 0 to Count - 1 do
        if Params[i].IsVarParam then
          dItem[i].Value := Temp1[i];
  finally
    Temp1 := nil;
    LocalVars.Free;
    FVarsStack.Delete(StackIndex);
  end;
end;


{ TfsPropertyHelper }

function TfsPropertyHelper.GetValue: Variant;
var
  p: PPropInfo;
  Instance: TObject;
begin

  Result := Null;
  Instance := TObject(frxInteger(ParentValue));

  if FIsPublished and Assigned(Instance) then
  begin
    p := GetPropInfo(Instance.ClassInfo, Name);
    if p <> nil then
      case p.PropType^.Kind of
        tkInteger, tkSet, tkEnumeration, tkClass
        {$IFDEF FPC} ,tkBool {$ENDIF}:
          Result := GetOrdProp(Instance, p);
{$IFDEF FS_INT64}
        tkInt64:
          Result := GetInt64Prop(Instance, p);
{$ENDIF}
        tkFloat:
          Result := GetFloatProp(Instance, p);

//        tkString, tkLString, tkWString{$IFDEF Delphi12}, tkUString{$ENDIF}:
//          Result := GetStrProp(Instance, p);

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

        tkVariant:
          Result := GetVariantProp(Instance, p);
{$IFDEF Delphi12}
        tkString, tkLString:
          Result := GetAnsiStrProp(Instance, p);
        tkWString, tkUString:
          Result := GetUnicodeStrProp(Instance, p);
{$ELSE}
        tkString, tkLString, tkWString{$ifdef FPC}, tkAString{$endif}:
          Result := GetStrProp(Instance, p);
{$ENDIF}
      end;
  end
  else if Assigned(FOnGetValue) then
    Result := FOnGetValue(Instance, FClassRef, FUppercaseName)
  else if Assigned(FOnGetValueNew) then
    Result := FOnGetValueNew(Instance, FClassRef, FUppercaseName, Self);

  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: frxInteger;
  Int64Val: Int64;
begin

  if IsReadOnly then Exit;
  Instance := TObject(frxInteger(ParentValue));



  if FIsPublished then
  begin
    p := GetPropInfo(Instance.ClassInfo, Name);
    if p <> nil then
      case p.PropType^.Kind of
        tkInteger, tkSet, tkEnumeration, tkClass
        {$IFDEF FPC} ,tkBool {$ENDIF}:
//        {$IFDEF Delphi12}, tkInt64{$ENDIF}:
        begin
{$IFNDEF Delphi4}
          if VarType(Value) <> varInteger then
          begin
            SetSetProp(Instance, p, fsSetToString(p, Value));
          end
          else
{$ENDIF}
          begin
            if Typ = fvtBool then
              if Value = True then
                IntVal := 1 else
                IntVal := 0
            else
{$IFNDEF CPUX64}
{$IFDEF Delphi12}
              if (VarType(Value) = varInt64)
               or (VarType(Value) = varUInt64) then
                begin
                  Int64Val := Value;
                  IntVal := Cardinal(Int64Rec(Int64Val).Lo);
                end
              else
{$ENDIF}
{$ENDIF}
                IntVal := frxInteger(Value);
            SetOrdProp(Instance, p, IntVal);
          end;
        end;
{$IFNDEF DELPHI16}
{$IFDEF FS_INT64}
        tkInt64:
          SetInt64Prop(Instance, p, Value);
{$ENDIF}
{$ELSE}
        tkInt64:
          SetInt64Prop(Instance, p, Int64(Value));
{$ENDIF}
        tkFloat:
          SetFloatProp(Instance, p, Extended(Value));

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

//        tkWString{$IFDEF Delphi12}, tkUString{$ENDIF}:
//          SetStrProp(Instance, p, WideString(Value));

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

        tkVariant:
          SetVariantProp(Instance, p, Value);

{$IFDEF Delphi12}
        tkString, tkLString:
          SetAnsiStrProp(Instance, p, AnsiString(Value));
        tkWString, tkUString:
          SetUnicodeStrProp(Instance, p, WideString(Value));
{$ELSE}
        tkString, tkLString, tkWString{$ifdef FPC}, tkAString{$endif}:
          SetStrProp(Instance, p, String(Value));
{$ENDIF}
      end;
  end
  else if Assigned(FOnSetValue) then
    FOnSetValue(Instance, FClassRef, FUppercaseName, Value)
  else if Assigned(FOnSetValueNew) then
    FOnSetValueNew(Instance, FClassRef, FUppercaseName, Value, Self);

end;


{ TfsMethodHelper }

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

  { 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;

  // FPC and Delphi do this different way. FPC implementation more honest, so
  // if Count = 0 then we get exception about bad bounds
  if Count > 0 then
    FVarArray := VarArrayCreate([0, Count - 1], varVariant);
end;

destructor TfsMethodHelper.Destroy;
begin
  FVarArray := Null;
  inherited;
end;

function TfsMethodHelper.GetVParam(Index: Integer): Variant;
begin
  if Index = Count then
    Result := FSetValue
  else
    Result := TfsParamItem(FItems[Index]).Value;
end;

procedure TfsMethodHelper.SetVParam(Index: Integer; const Value: Variant);
begin
  TfsParamItem(FItems[Index]).Value := Value;
end;

function TfsMethodHelper.GetValue: Variant;
var
  i: Integer;
  Instance: TObject;
begin
  if Assigned(FOnCall) then
  begin
    for i := 0 to Count - 1 do
      FVarArray[i] := inherited Params[i].Value;

    Instance := nil;
    if not VarIsNull(ParentValue) then
      Instance := TObject(frxInteger(ParentValue));

    if FIndexMethod then
      Result := FOnCall(Instance, FClassRef, FUppercaseName + '.GET', FVarArray)
    else
      Result := FOnCall(Instance, FClassRef, FUppercaseName, FVarArray);
    for i := 0 to Count - 1 do
    begin
      if inherited Params[i].IsVarParam then
        inherited Params[i].Value := FVarArray[i];
      FVarArray[i] := Null;
    end;
  end
  else if Assigned(FOnCallNew) then
  begin
    Instance := nil;
    if not VarIsNull(ParentValue) then
      Instance := TObject(frxInteger(ParentValue));

    if FIndexMethod then
      Result := FOnCallNew(Instance, FClassRef, FUppercaseName + '.GET', Self)
    else
      Result := FOnCallNew(Instance, FClassRef, FUppercaseName, Self);
  end
  else
    Result := 0;
end;

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

      FOnCall(TObject(frxInteger(ParentValue)), FClassRef, FUppercaseName + '.SET', v);
      v := Null;
    end
    else if Assigned(FOnCallNew) then
    begin
      FSetValue := Value;
      FOnCallNew(TObject(frxInteger(ParentValue)), FClassRef, FUppercaseName + '.SET', Self);
      FSetValue := Null;
    end;
end;


{ TfsComponentHelper }

constructor TfsComponentHelper.Create(const Name: String; const ClassName: String);
begin
  inherited Create(Name, fvtClass, ClassName);
end;

function TfsComponentHelper.GetValue: Variant;
var
  c: TObject;
begin
  c := TObject(frxInteger(ParentValue));
  if c is TComponent then
    c := TComponent(c).FindComponent(Name)
  else
    c := nil;
  if Assigned(c) then
    Result := frxInteger(c)
  else
    raise Exception.Create(Format(SComponentError, [Name]));
end;

procedure TfsComponentHelper.SetValue(const Value: Variant);
begin
  raise Exception.Create(Format(SComponentAssignError, [Name]));
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(frxInteger(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));
    FProgram.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.AddConstructor(Syntax: String;
  CallEvent: TfsCallMethodNewEvent);
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, FProgram);
  m.FOnCall := CallEvent;
  m.FClassRef := FClassRef;
  FMembers.Add(m);
end;

procedure TfsClassVariable.AddMethod(const Syntax: String; CallEvent: TfsCallMethodNewEvent);
var
  m: TfsMethodHelper;
begin
  m := TfsMethodHelper.Create(Syntax, FProgram);
  m.FOnCallNew := CallEvent;
  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.AddPropertyEx(const Name, Typ: String;
  GetEvent: TfsGetValueNewEvent; SetEvent: TfsSetValueNewEvent);
var
  p: TfsPropertyHelper;
begin
  p := TfsPropertyHelper.Create(Name, StrToVarType(Typ, FProgram), Typ);
  p.FClassRef := FClassRef;
  p.FOnGetValueNew := GetEvent;
  p.FOnSetValueNew := 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.AddDefaultProperty(const Name, Params,
  Typ: String; CallEvent: TfsCallMethodNewEvent; AReadOnly: Boolean);
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.AddIndexProperty(const Name, Params,
  Typ: String; CallEvent: TfsCallMethodNewEvent; AReadOnly: Boolean);
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;

function TfsClassVariable.AddComponent(c: TComponent): TfsComponentHelper;
var
  Helper: TfsCustomHelper;
begin
  { check if member alreeady exist }
  Helper := Find(c.Name);
  Result := nil;
  { member has different purpose, name conflict }
  if Helper is TfsComponentHelper then
    Result := TfsComponentHelper(Helper);
  if Assigned(Helper) then Exit;
  Result := TfsComponentHelper.Create(c.Name, c.ClassName);
  FMembers.Add(Result);
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;
{$IFDEF FS_INT64}
        tkInt64:
          t := fvtInt64;
{$ENDIF}
        tkSet:
          begin
            t := fvtEnum;
            cl := String(PropList[i].PropType^.Name);
          end;
        tkEnumeration:
          begin
            t := fvtEnum;
            cl := String(PropList[i].PropType^.Name);
            if (CompareText(cl, 'Boolean') = 0) or (CompareText(cl, 'bool') = 0) then
              t := fvtBool;
          end;
{$ifdef FPC}
        tkBool:
          t := fvtBool;
{$ENDIF}
        tkFloat:
          t := fvtFloat;
        tkChar, tkWChar:
          t := fvtChar;
        tkString, tkLString, tkWString{$IFDEF Delphi12}, tkUString{$ENDIF}{$ifdef FPC},tkAString{$endif}:
          t := fvtString;
        tkVariant:
          t := fvtVariant;
        tkClass:
          begin
            t := fvtClass;
          {$IFNDEF FPC}
            FClass := GetTypeData(PropList[i].PropType^).ClassType;
          {$ELSE}
            FClass := GetTypeData(PropList[i].PropType).ClassType;
          {$ENDIF}
            cl := FClass.ClassName;
          end;
      end;

      p := TfsPropertyHelper.Create(String(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; IncludeComponentHelper: Boolean = True): 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;
  if not IncludeComponentHelper and (Result is TfsComponentHelper) then
    Result := nil;
end;

function TfsClassVariable.GetValue: Variant;
begin
  if Params[0].Value = Null then
    Result := frxInteger(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);
var
  ParentProg: TfsScript;
begin
{$IFDEF CPUX64}
  inherited Create('', fvtInt64, '');
{$ELSE}
  inherited Create('', fvtInt, '');
{$ENDIF}
  FProgram := AProgram;
  FMainProg := FProgram;
  ParentProg := FProgram;
  while ParentProg <> nil do
    if ParentProg.FMainProg then
    begin
      FMainProg := ParentProg;
      break;
    end
    else
      ParentProg := ParentProg.FParent;
  FProgram.UseClassLateBinding := FMainProg.UseClassLateBinding;
end;

destructor TfsDesignator.Destroy;
begin
  if FLateBindingXMLSource <> nil then
    FLateBindingXMLSource.Free;
  inherited;
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;
  Temp1: array of Variant;
  StackIndex: Integer;
begin
  Ref := nil;
  Val := Null;
  StackIndex := -1;
  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;

    try
      { 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
        StackIndex := TfsProcVariable(Item).SaveLocalVariables;

      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
            if Item.IsMacro then
              Temp1[j] := TfsExpression(Items[i][j]).Source
            else
              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
      begin
        Item.Value := AValue
      end
      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;

    finally
      { restore proc variables if it was called from itself }
      if (Item is TfsProcVariable) and TfsProcVariable(Item).Executing then
        TfsProcVariable(Item).RestoreLocalVariables(StackIndex, False, Items[i]);
    end;
  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] := Null else
      Result[i] := Items[i].Value;
end;


{ TfsScript }

constructor TfsScript.Create(AOwner: TComponent);
begin
  inherited;
  FEvaluteRiseError := False;
  FItems := TStringList.Create;
  FItems.Sorted := True;
  FItems.Duplicates := dupAccept;
  FLines := TStringList.Create;
  FMacros := TStringList.Create;
  FIncludePath := TStringList.Create;
  FIncludePath.Add('');
  FStatement := TfsStatement.Create(Self, '', '');
  FSyntaxType := 'PascalScript';
  FUnitLines := TStringList.Create;
  FUseClassLateBinding := False;
end;

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

procedure TfsScript.Add(const Name: String; Item: TObject);
begin
  FItems.AddObject(Name, Item);
  if Item is TfsCustomVariable then
    TfsCustomVariable(Item).AddedBy := FAddedBy;
end;

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

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

procedure TfsScript.Clear;
var
  i: Integer;
  item: TObject;
begin
  i := 0;
  while i < FItems.Count do
  begin
    item := FItems.Objects[i];
    if (item is TfsRTTIModule) or
      ((item is TfsCustomVariable) and
       (TfsCustomVariable(item).AddedBy = TObject(1))) then
      Inc(i)
    else
    begin
      item.Free;
      FItems.Delete(i);
    end;
  end;
  FStatement.Clear;


  for i := 0 to FUnitLines.Count - 1 do
    FUnitLines.Objects[i].Free;

  FUnitLines.Clear;

  FErrorPos := '';
  FErrorMsg := '';
  FErrorUnit := '';
end;

procedure TfsScript.ClearItems(Owner: TObject);
var
    i: Integer;
begin
  RemoveItems(Owner);
  FStatement.Clear;

  for i := 0 to FUnitLines.Count - 1 do
    FUnitLines.Objects[i].Free;

  FUnitLines.Clear;
end;

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

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

function TfsScript.GetProgName: String;
begin
  if Assigned(ProgRunning) then
    Result := ProgRunning.ProgName
  else
    Result := FProgName;
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;
  i := FItems.IndexOf(Name);
  if (i <> -1) and (FItems.Objects[i] is TfsCustomVariable) then
    Result := TfsCustomVariable(FItems.Objects[i]);
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

  FExitCalled := False;
  FTerminated := False;
  FIsRunning := True;
  FMainProg := True;
  try
    FStatement.Execute;
  finally
    FExitCalled := False;
    FTerminated := False;
    FIsRunning := False;
  end;
end;

function TfsScript.Run: Boolean;
begin
  Result := Compile;
  if Result then
    Execute;
end;

function TfsScript.GetILCode(Stream: TStream): Boolean;
var
  p: TfsILParser;
begin
  Result := False;
  FErrorMsg := '';

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

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

function TfsScript.SetILCode(Stream: TStream): Boolean;
var
  p: TfsILParser;
begin
  Result := False;
  FErrorMsg := '';

  p := TfsILParser.Create(Self);
  try
    p.SelectLanguage(FSyntaxType);
    p.ILScript.LoadFromStream(Stream);
    p.ParseILScript;
  finally
    p.Free;
  end;

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

procedure TfsScript.AddType(const TypeName: String; ParentType: TfsVarType);
var
  v: TfsTypeVariable;
begin
  if Find(TypeName) <> nil then Exit;
  v := TfsTypeVariable.Create(TypeName, ParentType, '');
  Add(TypeName, v);
end;

function TfsScript.AddClass(AClass: TClass; const Ancestor: String): TfsClassVariable;
var
  cl: TfsClassVariable;
begin
  Result := nil;
  if Find(AClass.ClassName) <> nil then Exit;

  Result := TfsClassVariable.Create(AClass, Ancestor);
  Result.FProgram := Self;
  Add(Result.Name, Result);

  cl := TfsClassVariable(Find(Ancestor));
  if cl <> nil then
    Result.FDefProperty := cl.DefProperty;
end;

procedure TfsScript.AddConst(const Name, Typ: String; const Value: Variant);
var
  v: TfsVariable;
begin
  if Find(Name) <> nil then Exit;

  v := TfsVariable.Create(Name, StrToVarType(Typ, Self), Typ);
  v.Value := Value;
  v.IsReadOnly := True;
  Add(v.Name, v);
end;

procedure TfsScript.AddEnum(const Typ, Names: String);
var
  i: Integer;
  v: TfsVariable;
  sl: TStringList;
begin
  v := TfsVariable.Create(Typ, fvtEnum, Typ);
  Add(v.Name, v);

  sl := TStringList.Create;
  sl.CommaText := Names;

  try
    for i := 0 to sl.Count - 1 do
    begin
      v := TfsVariable.Create(Trim(sl[i]), fvtEnum, Typ);
      v.Value := i;
      v.IsReadOnly := True;
      Add(v.Name, v);
    end;
  finally
    sl.Free;
  end;
end;

procedure TfsScript.AddEnumSet(const Typ, Names: String);
var
  i, j: Integer;
  v: TfsVariable;
  sl: TStringList;
begin
  v := TfsVariable.Create(Typ, fvtEnum, Typ);
  Add(v.Name, v);

  sl := TStringList.Create;
  sl.CommaText := Names;

  try
    j := 1;
    for i := 0 to sl.Count - 1 do
    begin
      v := TfsVariable.Create(Trim(sl[i]), fvtEnum, Typ);
      v.Value := j;
      v.IsReadOnly := True;
      Add(v.Name, v);
      j := j * 2;
    end;
  finally
    sl.Free;
  end;
end;

procedure TfsScript.AddMethod(const Syntax: String; CallEvent: TfsCallMethodEvent;
  const Category: String = ''; const Description: String = '');
var
  v: TfsMethodHelper;
begin
  v := TfsMethodHelper.Create(Syntax, Self);
  v.FOnCall := CallEvent;
  if Description = '' then
    v.FDescription := v.Name else
    v.FDescription := Description;
  v.FCategory := Category;
  Add(v.Name, v);
end;

procedure TfsScript.AddMethod(const Syntax: String; CallEvent: TfsCallMethodNewEvent;
  const Category: String = ''; const Description: String = '');
var
  v: TfsMethodHelper;
begin
  v := TfsMethodHelper.Create(Syntax, Self);
  v.FOnCallNew := CallEvent;
  if Description = '' then
    v.FDescription := v.Name else
    v.FDescription := Description;
  v.FCategory := Category;
  Add(v.Name, v);
end;

procedure TfsScript.AddObject(const Name: String; Obj: TObject);
begin
  AddVariable(Name, Obj.ClassName, frxInteger(Obj));
end;

procedure TfsScript.AddVariable(const Name, Typ: String; const Value: Variant);
var
  v: TfsVariable;
begin
  if Find(Name) <> nil then Exit;

  v := TfsVariable.Create(Name, StrToVarType(Typ, Self), Typ);
  v.Value := Value;
  v.OnGetVarValue := FOnGetVarValue;
  Add(v.Name, v);
end;

procedure TfsScript.AddForm(Form: TComponent);
begin
  AddComponent(Form);
end;

procedure TfsScript.AddComponent(Form: TComponent);
{$IFNDEF NOFORMS}
var
  i: Integer;
  v: TfsClassVariable;
{$ENDIF}
begin
{$IFNDEF NOFORMS}
  v := FindClass(Form.ClassName);
  if v = nil then
  begin
    if Form.InheritsFrom(TForm) then
      AddClass(Form.ClassType, 'TForm')
    else if Form.InheritsFrom(TDataModule) then
      AddClass(Form.ClassType, 'TDataModule')
{$IFNDEF FMX}
{$IFDEF Delphi5}
    else if Form.InheritsFrom(TFrame) then
      AddClass(Form.ClassType, 'TFrame')
{$ENDIF}
{$ENDIF}
    else
      Exit;
    v := FindClass(Form.ClassName);
  end;

  for i := 0 to Form.ComponentCount - 1 do
    v.AddComponent(Form.Components[i]);
  AddObject(Form.Name, Form);
{$ENDIF}
end;

procedure TfsScript.AddRTTI;
var
  i: Integer;
  rtti: TfsRTTIModule;
  obj: TClass;
begin
  if FRTTIAdded then Exit;

  AddedBy := TObject(1); // do not clear
  for i := 0 to FRTTIModules.Count - 1 do
  begin
    obj := TClass(FRTTIModules[i]);
    rtti := TfsRTTIModule(obj.NewInstance);
    rtti.Create(Self);
    Add('', rtti);
  end;
  AddedBy := nil;

  FRTTIAdded := True;
end;

procedure TfsScript.ClearRTTI;
var
  i: Integer;
  item: TObject;
begin
  if not FRTTIAdded then Exit;

  i := 0;
  while i < FItems.Count do
  begin
    item := FItems.Objects[i];
    if (item is TfsRTTIModule) or
      ((item is TfsCustomVariable) and
       (TfsCustomVariable(item).AddedBy = TObject(1))) then
    begin
      item.Free;
      FItems.Delete(i);
    end
    else
      Inc(i);
  end;

  FRTTIAdded := False;
end;

function TfsScript.CallFunction(const Name: String; const Params: Variant; sGlobal: Boolean): Variant;
var
  i, StackIndex: Integer;
  v: TfsCustomVariable;
  p: TfsProcVariable;
begin
  if sGlobal then
    v := Find(Name)
  else
    v := FindLocal(Name);
  if (v <> nil) and (v is TfsProcVariable) then
  begin
    p := TfsProcVariable(v);

    StackIndex := -1;
    if p.Executing then
      StackIndex := p.SaveLocalVariables;
    try
      if VarIsArray(Params) then
        for i := 0 to VarArrayHighBound(Params, 1) do
          p.Params[i].Value := Params[i];
      Result := p.Value;
    finally
      p.RestoreLocalVariables(StackIndex, True);
    end;
  end
  else
  begin
    Result := Null;
  end
end;

function TfsScript.CallFunction1(const Name: String; var Params: Variant; sGlobal: Boolean): Variant;
var
  i, StackIndex: Integer;
  v: TfsCustomVariable;
  p: TfsProcVariable;
begin
  if sGlobal then
    v := Find(Name)
  else
    v := FindLocal(Name);
  if (v <> nil) and (v is TfsProcVariable) then
  begin
    p := TfsProcVariable(v);

    StackIndex := -1;
    if p.Executing then
      StackIndex := p.SaveLocalVariables;
    try
      if VarIsArray(Params) then
        for i := 0 to VarArrayHighBound(Params, 1) do
          p.Params[i].Value := Params[i];
      Result := p.Value;
      if VarIsArray(Params) then
        for i := 0 to VarArrayHighBound(Params, 1) do
          Params[i] := p.Params[i].Value;
    finally
      p.RestoreLocalVariables(StackIndex, True);
    end;
  end
  else
    Result := Null;
end;

function TfsScript.CallFunction2(const Func: TfsProcVariable; const Params: Variant): Variant;
var
  i, StackIndex: Integer;
begin
  if (Func <> nil) then
  begin
    StackIndex := -1;
    if Func.Executing then
      StackIndex := Func.SaveLocalVariables;
    try
      if VarIsArray(Params) then
        for i := 0 to VarArrayHighBound(Params, 1) do
          Func.Params[i].Value := Params[i];
      Result := Func.Value;
    finally
      Func.RestoreLocalVariables(StackIndex, True);
    end;
  end
  else
  begin
    Result := Null;
  end
end;

function TfsScript.Evaluate(const Expression: String): Variant;
var
  p: TfsScript;
  Prog: TfsScript;
  SaveEvent: TfsRunLineEvent;
begin
  FEvaluteRiseError := False;
  Result := Null;
  if FProgRunning = nil then
    p := Self else
    p := FProgRunning;

  Prog := TfsScript.Create(nil);
  if not p.FRTTIAdded then
    Prog.AddRTTI;
  Prog.Parent := p;
  Prog.OnGetVarValue := p.OnGetVarValue;
  SaveEvent := FOnRunLine;
  FOnRunLine := nil;
  try
    prog.SyntaxType := SyntaxType;
    if CompareText(SyntaxType, 'PascalScript') = 0 then
      Prog.Lines.Text := 'function fsEvaluateFUNC: Variant; begin Result := ' + Expression + ' end; begin end.'
    else if CompareText(SyntaxType, 'C++Script') = 0 then
      Prog.Lines.Text := 'Variant fsEvaluateFUNC() { return ' + Expression + '; } {}'
    else if CompareText(SyntaxType, 'BasicScript') = 0 then
      Prog.Lines.Text := 'function fsEvaluateFUNC' + #13#10 + 'return ' + Expression + #13#10 + 'end function'
    else if CompareText(SyntaxType, 'JScript') = 0 then
      Prog.Lines.Text := 'function fsEvaluateFUNC() { return (' + Expression + '); }';
    if not Prog.Compile then
    begin
      Result := Prog.ErrorMsg;
      FEvaluteRiseError := True;
    end
    else
      Result := Prog.FindLocal('fsEvaluateFUNC').Value;
  finally
    Prog.Free;
    FOnRunLine := SaveEvent;
  end;
end;

function TfsScript.FindClass(const Name: String): TfsClassVariable;
var
  Item: TfsCustomVariable;
begin
  Item := Find(Name);
  if (Item <> nil) and (Item is TfsClassVariable) then
    Result := TfsClassVariable(Item) else
    Result := nil
end;

procedure TfsScript.RunLine(const UnitName, Index: String);
var
  p: TfsScript;
begin
  p := Self;
  while p <> nil do
    if Assigned(p.FOnRunLine) then
    begin
      p.FOnRunLine(Self, UnitName, Index);
      break;
    end
    else
      p := p.FParent;
end;

function TfsScript.GetVariables(Index: String): Variant;
var
  v: TfsCustomVariable;
begin
  v := Find(Index);
  if v <> nil then
    Result := v.Value else
    Result := Null;
end;

procedure TfsScript.SetVariables(Index: String; const Value: Variant);
var
  v: TfsCustomVariable;
begin
  v := Find(Index);
  if v <> nil then
    v.Value := Value else
    AddVariable(Index, 'Variant', Value);
end;

procedure TfsScript.SetLines(const Value: TStrings);
begin
  FLines.Assign(Value);
end;

procedure TfsScript.SetProgName(const Value: String);
begin
  if Assigned(FProgRunning) then
    FProgRunning.FProgName := Value
  else
    FProgName := Value;
end;

procedure TfsScript.Terminate;

  procedure TerminateAll(Script: TfsScript);
  var
    i: Integer;
  begin
    Script.FExitCalled := True;
    Script.FTerminated := True;
    for i := 0 to Script.Count - 1 do
      if Script.Items[i] is TfsProcVariable then
        TerminateAll(TfsProcVariable(Script.Items[i]).Prog);
  end;

begin
  TerminateAll(Self);
end;

procedure TfsScript.AddCodeLine(const UnitName, APos: String);
var
  sl: TStringList;
  LineN: String;
  i : Integer;
begin
  i := FUnitLines.IndexOf(UnitName);

  if (i = -1) then
  begin
    sl := TStringList.Create;
    sl.Sorted := True;
    FUnitLines.AddObject(UnitName, sl);
  end else
  begin
    sl := TStringList(FUnitLines.Objects[i]);
  end;

  LineN := Copy(APos, 1, Pos(':', APos) - 1);
  if sl.IndexOf(LineN) = -1 then
  begin
    sl.Add(LineN);
  end;
end;

function TfsScript.IsExecutableLine(LineN: Integer; const UnitName: String = ''): Boolean;
var
  sl: TStringList;
  i: Integer;
begin
  Result := False;

  i := FUnitLines.IndexOf(UnitName);
  if (i = -1) then Exit;

  sl := TStringList(FUnitLines.Objects[i]);
  if sl.IndexOf(IntToStr(LineN)) <> -1 then
    Result := True;
end;




{ TfsStatement }

constructor TfsStatement.Create(AProgram: TfsScript; const UnitName,
  SourcePos: String);
begin
  inherited Create;
  FProgram := AProgram;
  FSourcePos := SourcePos;
  FUnitName := UnitName;
end;

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

procedure TfsStatement.Execute;
var
  i: Integer;
begin
  FProgram.ErrorPos := '';
  for i := 0 to Count - 1 do
  begin
    if FProgram.FTerminated then break;
    try
      FProgram.FLastSourcePos := Items[i].FSourcePos;
      Items[i].Execute;
    except
      on E: Exception do
       begin
         if FProgram.ErrorPos = '' then
           FProgram.ErrorPos := FProgram.FLastSourcePos;
         raise;
       end;
    end;
    if FProgram.FBreakCalled or FProgram.FContinueCalled or
      FProgram.FExitCalled then break;
  end;
end;

procedure TfsStatement.RunLine;
begin
  FProgram.RunLine(FUnitName, FSourcePos);
end;


{ TfsAssignmentStmt }

destructor TfsAssignmentStmt.Destroy;
begin
  FDesignator.Free;
  FExpression.Free;
  inherited;
end;

procedure TfsAssignmentStmt.Optimize;
begin
  FVar := FDesignator;
  FExpr := FExpression;

  if FDesignator is TfsVariableDesignator then
    FVar := FDesignator.RefItem;
  if TfsExpression(FExpression).SingleItem <> nil then
    FExpr := TfsExpression(FExpression).SingleItem;
end;

procedure TfsAssignmentStmt.Execute;
begin
  RunLine;
  if FProgram.FTerminated then Exit;
  FVar.Value := FExpr.Value;
end;

procedure TfsAssignPlusStmt.Execute;
begin
  RunLine;
  if FProgram.FTerminated then Exit;
  FVar.Value := FVar.Value + FExpr.Value;
end;

procedure TfsAssignMinusStmt.Execute;
begin
  RunLine;
  if FProgram.FTerminated then Exit;
  FVar.Value := FVar.Value - FExpr.Value;
end;

procedure TfsAssignMulStmt.Execute;
begin
  RunLine;
  if FProgram.FTerminated then Exit;
  FVar.Value := FVar.Value * FExpr.Value;
end;

procedure TfsAssignDivStmt.Execute;
begin
  RunLine;
  if FProgram.FTerminated then Exit;
  FVar.Value := FVar.Value / FExpr.Value;
end;


{ TfsCallStmt }

destructor TfsCallStmt.Destroy;
begin
  FDesignator.Free;
  inherited;
end;

procedure TfsCallStmt.Execute;
begin
  RunLine;
  if FProgram.FTerminated then Exit;
  if FModificator = '' then
  begin
    FDesignator.NeedResult := False;
    FDesignator.Value;
  end
  else if FModificator = '+' then
    FDesignator.Value := FDesignator.Value + 1
  else if FModificator = '-' then
    FDesignator.Value := FDesignator.Value - 1
end;


{ TfsIfStmt }

constructor TfsIfStmt.Create(AProgram: TfsScript; const UnitName,
  SourcePos: String);
begin
  inherited;
  FElseStmt := TfsStatement.Create(FProgram, UnitName, SourcePos);
end;

destructor TfsIfStmt.Destroy;
begin
  FCondition.Free;
  FElseStmt.Free;
  inherited;
end;

procedure TfsIfStmt.Execute;
begin
  RunLine;
  if FProgram.FTerminated then Exit;
  if Boolean(FCondition.Value) = True then
    inherited Execute else
    FElseStmt.Execute;
end;


{ TfsRepeatStmt }

destructor TfsRepeatStmt.Destroy;
begin
  FCondition.Free;
  inherited;
end;

procedure TfsRepeatStmt.Execute;
begin
  RunLine;
  if FProgram.FTerminated then Exit;

  repeat
    inherited Execute;
    if FProgram.FBreakCalled or FProgram.FExitCalled then break;
    FProgram.FContinueCalled := False;
  until Boolean(FCondition.Value) = not FInverseCondition;

  FProgram.FBreakCalled := False;
end;


{ TfsWhileStmt }

destructor TfsWhileStmt.Destroy;
begin
  FCondition.Free;
  inherited;
end;

procedure TfsWhileStmt.Execute;
begin
  RunLine;
  if FProgram.FTerminated then Exit;

  while Boolean(FCondition.Value) = True do
  begin
    inherited Execute;
    if FProgram.FBreakCalled or FProgram.FExitCalled then break;
    FProgram.FContinueCalled := False;
  end;

  FProgram.FBreakCalled := False;
end;


{ TfsForStmt }

destructor TfsForStmt.Destroy;
begin
  FBeginValue.Free;
  FEndValue.Free;
  inherited;
end;

procedure TfsForStmt.Execute;
var
  i, bValue, eValue: Integer;
begin
  try
    bValue := FBeginValue.Value;
    eValue := FEndValue.Value;
  finally
    RunLine;
  end;
  if FProgram.FTerminated then Exit;

  if FDown then
    for i := bValue downto eValue do
    begin
      FVariable.FValue := i;
      inherited Execute;
      if FProgram.FBreakCalled or FProgram.FExitCalled then break;
      FProgram.FContinueCalled := False;
    end
  else
    for i := bValue to eValue do
    begin
      FVariable.FValue := i;
      inherited Execute;
      if FProgram.FBreakCalled or FProgram.FExitCalled then break;
      FProgram.FContinueCalled := False;
    end;

  FProgram.FBreakCalled := False;
end;


{ TfsVbForStmt }

destructor TfsVbForStmt.Destroy;
begin
  FBeginValue.Free;
  FEndValue.Free;
  if FStep <> nil then
    FStep.Free;
  inherited;
end;

procedure TfsVbForStmt.Execute;
var
  i, bValue, eValue, sValue: Variant;
  Down: Boolean;
begin
  bValue := FBeginValue.Value;
  eValue := FEndValue.Value;
  if FStep <> nil then
    sValue := FStep.Value else
    sValue := 1;
  Down := sValue < 0;

  RunLine;
  if FProgram.FTerminated then Exit;
  i := bValue;
  if Down then
    while i >= eValue do
    begin
      FVariable.FValue := i;
      inherited Execute;
      if FProgram.FBreakCalled or FProgram.FExitCalled then break;
      FProgram.FContinueCalled := False;
      i := i + sValue;
    end
  else
    while i <= eValue do
    begin
      FVariable.FValue := i;
      inherited Execute;
      if FProgram.FBreakCalled or FProgram.FExitCalled then break;
      FProgram.FContinueCalled := False;
      i := i + sValue;
    end;

  FProgram.FBreakCalled := False;
end;


{ TfsCppForStmt }

constructor TfsCppForStmt.Create(AProgram: TfsScript; const UnitName,
  SourcePos: String);
begin
  inherited;
  FFirstStmt := TfsStatement.Create(FProgram, UnitName, SourcePos);
  FSecondStmt := TfsStatement.Create(FProgram, UnitName, SourcePos);
end;

destructor TfsCppForStmt.Destroy;
begin
  FFirstStmt.Free;
  FExpression.Free;
  FSecondStmt.Free;
  inherited;
end;

procedure TfsCppForStmt.Execute;
begin
  RunLine;
  if FProgram.FTerminated then Exit;
  FFirstStmt.Execute;
  if FProgram.FTerminated then Exit;
  while Boolean(FExpression.Value) = True do
  begin
    inherited Execute;
    if FProgram.FBreakCalled or FProgram.FExitCalled then break;
    FProgram.FContinueCalled := False;
    FSecondStmt.Execute;
  end;

  FProgram.FBreakCalled := False;
end;


{ TfsCaseSelector }

destructor TfsCaseSelector.Destroy;
begin
  FSetExpression.Free;
  inherited;
end;

function TfsCaseSelector.Check(const Value: Variant): Boolean;
begin
  Result := FSetExpression.Check(Value);
end;


{ TfsCaseStmt }

constructor TfsCaseStmt.Create(AProgram: TfsScript; const UnitName,
  SourcePos: String);
begin
  inherited;
  FElseStmt := TfsStatement.Create(FProgram, UnitName, SourcePos);
end;

destructor TfsCaseStmt.Destroy;
begin
  FCondition.Free;
  FElseStmt.Free;
  inherited;
end;

procedure TfsCaseStmt.Execute;
var
  i: Integer;
  Value: Variant;
  Executed: Boolean;
begin
  Value := FCondition.Value;
  Executed := False;

  RunLine;
  if FProgram.FTerminated then Exit;
  for i := 0 to Count - 1 do
    if TfsCaseSelector(Items[i]).Check(Value) then
    begin
      Items[i].Execute;
      Executed := True;
      break;
    end;

  if not Executed then
    FElseStmt.Execute;
end;


{ TfsTryStmt }

constructor TfsTryStmt.Create(AProgram: TfsScript; const UnitName,
  SourcePos: String);
begin
  inherited;
  FExceptStmt := TfsStatement.Create(AProgram, UnitName, SourcePos);
end;

destructor TfsTryStmt.Destroy;
begin
  FExceptStmt.Free;
  inherited;
end;

procedure TfsTryStmt.Execute;
var
  SaveExitCalled: Boolean;
begin
  RunLine;
  if FProgram.FTerminated then Exit;
  if IsExcept then
  begin
    try
      inherited Execute;
    except
      on E: Exception do
      begin
        FProgram.SetVariables('ExceptionClassName', E.ClassName);
        FProgram.SetVariables('ExceptionMessage', E.Message);
        FProgram.ErrorPos := FProgram.FLastSourcePos;
        ExceptStmt.Execute;
      end;
    end;
  end
  else
  begin
    try
      inherited Execute;
    finally
      SaveExitCalled := FProgram.FExitCalled;
      FProgram.FExitCalled := False;
      ExceptStmt.Execute;
      FProgram.FExitCalled := SaveExitCalled;
    end
  end;
end;

{ TfsBreakStmt }

procedure TfsBreakStmt.Execute;
begin
  FProgram.FBreakCalled := True;
end;


{ TfsContinueStmt }

procedure TfsContinueStmt.Execute;
begin
  FProgram.FContinueCalled := True;
end;


{ TfsExitStmt }

procedure TfsExitStmt.Execute;
begin
  RunLine;
  FProgram.FExitCalled := True;
end;


{ TfsWithStmt }

destructor TfsWithStmt.Destroy;
begin
  FDesignator.Free;
  inherited;
end;

procedure TfsWithStmt.Execute;
begin
  inherited;
  FVariable.Value := FDesignator.Value;
end;


{ TfsArrayHelper }

constructor TfsArrayHelper.Create(const AName: String; DimCount: Integer;
  Typ: TfsVarType; const TypeName: String);
var
  i: Integer;
begin
  inherited Create(AName, Typ, TypeName);

  if DimCount <> -1 then
  begin
    for i := 0 to DimCount - 1 do
{$IFDEF CPUX64}
      Add(TfsParamItem.Create('', fvtInt64, '', False, False));
{$ELSE}
      Add(TfsParamItem.Create('', fvtInt, '', False, False));
{$ENDIF}
  end
  else
    for i := 0 to 2 do
{$IFDEF CPUX64}
      Add(TfsParamItem.Create('', fvtInt64, '', i > 0, False));
{$ELSE}
      Add(TfsParamItem.Create('', fvtInt, '', i > 0, False));
{$ENDIF}
end;

destructor TfsArrayHelper.Destroy;
begin
  inherited;
end;

function TfsArrayHelper.GetValue: Variant;
var
  DimCount: Integer;
begin
  DimCount := VarArrayDimCount(ParentRef.PValue^);
  case DimCount of
    1: Result := ParentRef.PValue^[Params[0].Value];
    2: Result := ParentRef.PValue^[Params[0].Value, Params[1].Value];
    3: Result := ParentRef.PValue^[Params[0].Value, Params[1].Value, Params[2].Value];
  else
    Result := Null;
  end;
end;

procedure TfsArrayHelper.SetValue(const Value: Variant);
var
  DimCount: Integer;
begin
  DimCount := VarArrayDimCount(ParentRef.PValue^);
  case DimCount of
    1: ParentRef.PValue^[Params[0].Value] := Value;
    2: ParentRef.PValue^[Params[0].Value, Params[1].Value] := Value;
    3: ParentRef.PValue^[Params[0].Value, Params[1].Value, Params[2].Value] := Value;
  end;
end;


{ TfsStringHelper }

constructor TfsStringHelper.Create;
begin
  inherited Create('__StringHelper', fvtChar, '');
  Add(TfsParamItem.Create('', fvtInt, '', False, False));
end;

function TfsStringHelper.GetValue: Variant;
begin
  Result := String(ParentValue)[Integer(Params[0].Value)];
end;

procedure TfsStringHelper.SetValue(const Value: Variant);
var
  s: String;
begin
  s := ParentValue;
  s[Integer(Params[0].Value)] := String(Value)[1];
  TfsCustomVariable(frxInteger(ParentRef)).Value := s;
end;


{ TfsCustomEvent }

constructor TfsCustomEvent.Create(AObject: TObject; AHandler: TfsProcVariable);
begin
  FInstance := AObject;
  FHandler := AHandler;
end;

procedure TfsCustomEvent.CallHandler(Params: array of const);
var
  i, StackIndex: Integer;
begin
  StackIndex := -1;
  if FHandler.Executing then
    StackIndex := FHandler.SaveLocalVariables;
  try
    for i := 0 to FHandler.Count - 1 do
      FHandler.Params[i].Value := VarRecToVariant(Params[i]);
    FHandler.Value;
  finally
    FHandler.RestoreLocalVariables(StackIndex, True);
  end;
end;


{ TfsRTTIModule }

constructor TfsRTTIModule.Create(AScript: TfsScript);
begin
  FScript := AScript;
end;


function fsGlobalUnit: TfsScript;
begin
  if (FGlobalUnit = nil) and not FGlobalUnitDestroyed then
  begin
    FGlobalUnit := TfsScript.Create(nil);
    FGlobalUnit.AddRTTI;
  end;
  Result := FGlobalUnit;
end;

function fsIsGlobalUnitExist: Boolean;
begin
  Result := Assigned(FGlobalUnit);
end;

function fsRTTIModules: TList;
begin
  if (FRTTIModules = nil) and not FRTTIModulesDestroyed then
  begin
    FRTTIModules := TList.Create;
    FRTTIModules.Add(TfsSysFunctions);
  end;
  Result := FRTTIModules;
end;

{ TfsVariable }

function TfsVariable.GetValue: Variant;
begin
  Result := inherited GetValue;
  if Assigned(FOnGetVarValue) then
  begin
    Result := FOnGetVarValue(FName, FTyp, FValue);
    if Result = null then Result := FValue;
  end;
end;

procedure TfsVariable.SetValue(const Value: Variant);
begin
  if not FIsReadOnly then
    case FTyp of
      fvtInt: FValue := VarAsType(Value, varInteger);
{$IFDEF FS_INT64}
      fvtInt64: FValue := VarAsType(Value, varInt64);
{$ENDIF}
      fvtBool: FValue := VarAsType(Value, varBoolean);
      fvtFloat:
        if (VarType(Value) = varDate) then
          FValue := VarAsType(Value, varDate)
        else
          FValue := VarAsType(Value, varDouble);
{$IFDEF Delphi12}
      fvtString: FValue := VarAsType(Value, varUString);
{$ELSE}
      fvtString: FValue := VarAsType(Value, varString);
{$ENDIF}
    else
      FValue := Value;
    end;
end;

initialization
{$IFDEF FMX}
  StartClassGroup(TFmxObject);
  ActivateClassGroup(TFmxObject);
  GroupDescendentsWith(TfsScript, TFmxObject);
{$ELSE}
{$IFDEF Delphi16}
  StartClassGroup(TControl);
  ActivateClassGroup(TControl);
  GroupDescendentsWith(TfsScript, TControl);
{$ENDIF}
{$ENDIF}
  FGlobalUnitDestroyed := False;
  FRTTIModulesDestroyed := False;
  fsRTTIModules;

finalization
  if FGlobalUnit <> nil then
    FGlobalUnit.Free;
  FGlobalUnit := nil;
  FGlobalUnitDestroyed := True;
  FRTTIModules.Free;
  FRTTIModules := nil;
  FRTTIModulesDestroyed := True;

end.