rm_jvinterpreter.pas

来自「胜天进销存源码,国产优秀的进销存」· PAS 代码 · 共 1,771 行 · 第 1/5 页

    procedure Sort(Compare: TListSortCompare = nil); override;
  end;

  IJvInterpreterDataType = interface
    ['{8C5E4071-65AB-11D7-B235-00A0D2043DC7}']
    procedure Init(var V: Variant);
    function GetTyp: Word;
  end;

  TCallConvention = set of (ccFastCall, ccStdCall, ccCDecl, ccDynamic,
    ccVirtual, ccClass);
  { TJvInterpreterAdapter - route JvInterpreter calls to Delphi functions }
  TJvInterpreterAdapter = class(TObject)
  private
    FOwner: TJvInterpreterExpression;
    FSrcUnitList: TJvInterpreterIdentifierList; // JvInterpreter-units sources
    FExtUnitList: TJvInterpreterIdentifierList; // internal units; like "system" in delphi
    FGetList: TJvInterpreterIdentifierList; // methods
    FSetList: TJvInterpreterIdentifierList; // write properties
    FIGetList: TJvInterpreterIdentifierList; // read indexed properties
    FISetList: TJvInterpreterIdentifierList; // write indexed properties
    FIDGetList: TJvInterpreterIdentifierList; // read default indexed properties
    FIDSetList: TJvInterpreterIdentifierList; // write default indexed properties
    FIntfGetList: TJvInterpreterIdentifierList; // interface methods
    FDGetList: TJvInterpreterIdentifierList; // direct get list
    FClassList: TJvInterpreterIdentifierList; // delphi classes
    FConstList: TJvInterpreterIdentifierList; // delphi consts
    FFunList: TJvInterpreterIdentifierList; // functions, procedures
    FRecList: TJvInterpreterIdentifierList; // records
    FRecGetList: TJvInterpreterIdentifierList; // read record field
    FRecSetList: TJvInterpreterIdentifierList; // write record field
    FOnGetList: TJvInterpreterIdentifierList; // chain
    FOnSetList: TJvInterpreterIdentifierList; // chain
    FSrcFunList: TJvInterpreterIdentifierList; // functions, procedures in JvInterpreter-source
    FExtFunList: TJvInterpreterIdentifierList;
    FEventHandlerList: TJvInterpreterIdentifierList;
    FEventList: TJvInterpreterIdentifierList;
    FSrcVarList: TJvInterpreterVarList; // variables, constants in JvInterpreter-source
    FSrcClassList: TJvInterpreterIdentifierList; // JvInterpreter-source classes
    FSorted: Boolean;
    procedure CheckArgs(var Args: TJvInterpreterArgs; ParamCount: Integer;
      var ParamTypes: TTypeArray);
    function GetRec(RecordType: string): TObject;
{$IFDEF JvInterpreter_OLEAUTO}
    function DispatchCall(Identifier: string; var Value: Variant;
      Args: TJvInterpreterArgs; Get: Boolean): Boolean; stdcall;
{$ENDIF JvInterpreter_OLEAUTO}
    function GetValueRTTI(Identifier: string; var Value: Variant;
      Args: TJvInterpreterArgs): Boolean;
    function SetValueRTTI(Identifier: string; const Value: Variant;
      Args: TJvInterpreterArgs): Boolean;
  protected
    procedure CheckAction(Expression: TJvInterpreterExpression; Args: TJvInterpreterArgs;
      Data: Pointer); virtual;
    function GetValue(Expression: TJvInterpreterExpression; Identifier: string;
      var Value: Variant; Args: TJvInterpreterArgs): Boolean; virtual;
    function SetValue(Expression: TJvInterpreterExpression; Identifier: string;
      const Value: Variant; Args: TJvInterpreterArgs): Boolean; virtual;
    function GetElement(Expression: TJvInterpreterExpression; const Variable: Variant;
      var Value: Variant; var Args: TJvInterpreterArgs): Boolean; virtual;
    function SetElement(Expression: TJvInterpreterExpression; var Variable: Variant;
      const Value: Variant; var Args: TJvInterpreterArgs): Boolean; virtual;
    function NewRecord(const RecordType: string; var Value: Variant): Boolean; virtual;
    function FindFunDesc(const UnitName: string; const Identifier: string): TJvInterpreterFunDesc; virtual;
    procedure CurUnitChanged(NewUnitName: string; var Source: string); virtual;
    function UnitExists(const Identifier: string): Boolean; virtual;
    function IsEvent(Obj: TObject; const Identifier: string): Boolean; virtual;
    function NewEvent(const aUnitName: string; const aFunctionName, aEventType: string;
      AOwner: TJvInterpreterExpression; AObject: TObject): TSimpleEvent; virtual;
    procedure ClearSource; dynamic;
    procedure ClearNonSource; dynamic;
    procedure Sort; dynamic;
  protected
    { for internal use }
    procedure AddSrcClass(JvInterpreterSrcClass: TJvInterpreterIdentifier); virtual;
    function GetSrcClass(Identifier: string): TJvInterpreterIdentifier; virtual;
  public
    constructor Create(AOwner: TJvInterpreterExpression);
    destructor Destroy; override;
    function SetRecord(var Value: Variant): Boolean; virtual;
    procedure Clear; dynamic;
    procedure Assign(Source: TJvInterpreterAdapter); dynamic;
    procedure AddSrcUnit(Identifier: string; Source: string; UsesList: string);
      dynamic;
    procedure AddSrcUnitEx(Identifier: string; Source: string; UsesList: string;
      Data: Pointer); dynamic;
    procedure AddExtUnit(Identifier: string); dynamic;
    procedure AddExtUnitEx(Identifier: string; Data: Pointer); dynamic;
    procedure AddClass(UnitName: string; AClassType: TClass; Identifier: string);
      dynamic;
    procedure AddClassEx(UnitName: string; AClassType: TClass; Identifier: string;
      Data: Pointer); dynamic;
    procedure AddIntfGet(IID: TGUID; Identifier: string;
      GetFunc: TJvInterpreterAdapterGetValue; ParamCount: Integer;
      ParamTypes: array of Word; ResTyp: Word);
    procedure AddIntfGetEx(IID: TGUID; Identifier: string;
      GetFunc: TJvInterpreterAdapterGetValue; ParamCount: Integer;
      ParamTypes: array of Word; ResTyp: Word; Data: Pointer);
    procedure AddGet(AClassType: TClass; Identifier: string;
      GetFunc: TJvInterpreterAdapterGetValue; ParamCount: Integer;
      ParamTypes: array of Word; ResTyp: Word); dynamic;
    procedure AddGetEx(AClassType: TClass; Identifier: string;
      GetFunc: TJvInterpreterAdapterGetValue; ParamCount: Integer;
      ParamTypes: array of Word; ResTyp: Word; Data: Pointer); dynamic;
    procedure AddSet(AClassType: TClass; Identifier: string;
      SetFunc: TJvInterpreterAdapterSetValue; ParamCount: Integer;
      ParamTypes: array of Word); dynamic;
    procedure AddSetEx(AClassType: TClass; Identifier: string;
      SetFunc: TJvInterpreterAdapterSetValue; ParamCount: Integer;
      ParamTypes: array of Word; Data: Pointer); dynamic;
    procedure AddIGet(AClassType: TClass; Identifier: string;
      GetFunc: TJvInterpreterAdapterGetValue; ParamCount: Integer;
      ParamTypes: array of Word; ResTyp: Word); dynamic;
    procedure AddIGetEx(AClassType: TClass; Identifier: string;
      GetFunc: TJvInterpreterAdapterGetValue; ParamCount: Integer;
      ParamTypes: array of Word; ResTyp: Word; Data: Pointer); dynamic;
    procedure AddISet(AClassType: TClass; Identifier: string;
      SetFunc: TJvInterpreterAdapterSetValue; ParamCount: Integer;
      ParamTypes: array of Word); dynamic;
    procedure AddISetEx(AClassType: TClass; Identifier: string;
      SetFunc: TJvInterpreterAdapterSetValue; ParamCount: Integer;
      ParamTypes: array of Word; Data: Pointer); dynamic;
    procedure AddIDGet(AClassType: TClass;
      GetFunc: TJvInterpreterAdapterGetValue; ParamCount: Integer;
      ParamTypes: array of Word; ResTyp: Word); dynamic;
    procedure AddIDGetEx(AClassType: TClass;
      GetFunc: TJvInterpreterAdapterGetValue; ParamCount: Integer;
      ParamTypes: array of Word; ResTyp: Word; Data: Pointer); dynamic;
    procedure AddIDSet(AClassType: TClass;
      SetFunc: TJvInterpreterAdapterSetValue; ParamCount: Integer;
      ParamTypes: array of Word); dynamic;
    procedure AddIDSetEx(AClassType: TClass;
      SetFunc: TJvInterpreterAdapterSetValue; ParamCount: Integer;
      ParamTypes: array of Word; Data: Pointer); dynamic;
    procedure AddFunction(UnitName: string; Identifier: string;
      GetFunc: TJvInterpreterAdapterGetValue; ParamCount: Integer;
      ParamTypes: array of Word; ResTyp: Word); dynamic;
    procedure AddFunctionEx(UnitName: string; Identifier: string;
      GetFunc: TJvInterpreterAdapterGetValue; ParamCount: Integer;
      ParamTypes: array of Word; ResTyp: Word; Data: Pointer); dynamic;
    { function AddDGet under construction - don't use it }
    procedure AddDGet(AClassType: TClass; Identifier: string;
      GetFunc: Pointer; ParamCount: Integer; ParamTypes: array of Word;
      ResTyp: Word; CallConvention: TCallConvention); dynamic;
    procedure AddDGetEx(AClassType: TClass; Identifier: string;
      GetFunc: Pointer; ParamCount: Integer; ParamTypes: array of Word;
      ResTyp: Word; CallConvention: TCallConvention; Data: Pointer); dynamic;
    procedure AddRec(UnitName: string; Identifier: string; RecordSize: Integer;
      Fields: array of TJvInterpreterRecField; CreateFunc: TJvInterpreterAdapterNewRecord;
      DestroyFunc: TJvInterpreterAdapterDisposeRecord;
      CopyFunc: TJvInterpreterAdapterCopyRecord); dynamic;
    procedure AddRecEx(UnitName: string; Identifier: string; RecordSize: Integer;
      Fields: array of TJvInterpreterRecField; CreateFunc: TJvInterpreterAdapterNewRecord;
      DestroyFunc: TJvInterpreterAdapterDisposeRecord; CopyFunc: TJvInterpreterAdapterCopyRecord;
      Data: Pointer); dynamic;
    procedure AddRecGet(UnitName: string; RecordType: string; Identifier: string;
      GetFunc: TJvInterpreterAdapterGetValue; ParamCount: Integer;
      ParamTypes: array of Word; ResTyp: Word); dynamic;
    procedure AddRecGetEx(UnitName: string; RecordType: string; Identifier: string;
      GetFunc: TJvInterpreterAdapterGetValue; ParamCount: Integer;
      ParamTypes: array of Word; ResTyp: Word; Data: Pointer); dynamic;
    procedure AddRecSet(UnitName: string; RecordType: string; Identifier: string;
      SetFunc: TJvInterpreterAdapterSetValue; ParamCount: Integer;
      ParamTypes: array of Word); dynamic;
    procedure AddRecSetEx(UnitName: string; RecordType: string; Identifier: string;
      SetFunc: TJvInterpreterAdapterSetValue; ParamCount: Integer;
      ParamTypes: array of Word; Data: Pointer); dynamic;
    procedure AddConst(UnitName: string; Identifier: string; Value: Variant); dynamic;
    procedure AddConstEx(AUnitName: string; AIdentifier: string; AValue: Variant;
      AData: Pointer); dynamic;
    procedure AddExtFun(UnitName: string; Identifier: string; DllInstance: HINST;
      DllName: string; FunName: string; FunIndex: Integer; ParamCount: Integer;
      ParamTypes: array of Word; ResTyp: Word); dynamic;
    procedure AddExtFunEx(AUnitName: string; AIdentifier: string; ADllInstance: HINST;
      ADllName: string; AFunName: string; AFunIndex: Integer; AParamCount: Integer;
      AParamTypes: array of Word; AResTyp: Word; AData: Pointer); dynamic;
    procedure AddSrcFun(UnitName: string; Identifier: string;
      PosBeg, PosEnd: Integer; ParamCount: Integer; ParamTypes: array of Word;
      ParamNames: array of string; ResTyp: Word;
      AResDataType: IJvInterpreterDataType;
      Data: Pointer); dynamic;
    procedure AddSrcFunEx(AUnitName: string; AIdentifier: string;
      APosBeg, APosEnd: Integer; AParamCount: Integer; AParamTypes: array of Word;
      AParamNames: array of string; AResTyp: Word;
      AResDataType: IJvInterpreterDataType;
      AData: Pointer); dynamic;
    procedure AddHandler(UnitName: string; Identifier: string;
      EventClass: TJvInterpreterEventClass; Code: Pointer); dynamic;
    procedure AddHandlerEx(AUnitName: string; AIdentifier: string;
      AEventClass: TJvInterpreterEventClass; ACode: Pointer; AData: Pointer); dynamic;
    procedure AddEvent(UnitName: string; AClassType: TClass;
      Identifier: string); dynamic;
    procedure AddEventEx(AUnitName: string; AClassType: TClass;
      AIdentifier: string; AData: Pointer); dynamic;
    procedure AddSrcVar(UnitName: string; Identifier, Typ: string; VTyp: Word;
      const Value: Variant; DataType: IJvInterpreterDataType); dynamic;
    procedure AddOnGet(Method: TJvInterpreterGetValue); dynamic;
    procedure AddOnSet(Method: TJvInterpreterSetValue); dynamic;
  end;

  TStackPtr = -1..cJvInterpreterStackMax;
  { Expression evaluator }
  TJvInterpreterExpression = class(TJvComponent)
  private
    Parser: TJvInterpreterParser;
    FVResult: Variant;
    ExpStack: array[0..cJvInterpreterStackMax] of Variant;
    ExpStackPtr: TStackPtr;
    Token1: Variant;
    FBacked: Boolean;
    TTyp1: TTokenTyp;
    TokenStr1: string;
    PrevTTyp: TTokenTyp;
    AllowAssignment: Boolean;
    FArgs: TJvInterpreterArgs; { data }
    Args: TJvInterpreterArgs; { pointer to current }
    FPStream: TStream; { parsed source }
    FParsed: Boolean;
    FAdapter: TJvInterpreterAdapter;
    FSharedAdapter: TJvInterpreterAdapter;
    FCompiled: Boolean;
    FBaseErrLine: Integer;
    FOnGetValue: TJvInterpreterGetValue;
    FOnSetValue: TJvInterpreterSetValue;
    FLastError: EJvInterpreterError;
    function GetSource: string;
    procedure SetSource(Value: string);
    procedure SetCurPos(Value: Integer);
    function GetCurPos: Integer;
    function GetTokenStr: string;
    procedure ReadArgs;
    procedure InternalGetValue(Obj: Pointer; ObjTyp: Word; var Result: Variant);
    function CallFunction(const FunName: string;
      Args: TJvInterpreterArgs; Params: array of Variant): Variant; virtual; abstract;
    function CallFunctionEx(Instance: TObject; const UnitName: string;
      const FunName: string; Args: TJvInterpreterArgs; Params: array of Variant): Variant; virtual; abstract;
  protected
    procedure UpdateExceptionPos(E: Exception; const UnitName: string);
    procedure Init; dynamic;
    procedure ErrorExpected(Exp: string);
    procedure ErrorNotImplemented(Message: string);
    function PosBeg: Integer;
    function PosEnd: Integer;
    procedure Back;
    procedure SafeBack; {? please don't use ?}
    function CreateAdapter: TJvInterpreterAdapter; dynamic;
    procedure ParseToken;
    procedure ReadToken;
    procedure WriteToken;
    procedure Parse;
    function Expression1: Variant;
    function Expression2(const ExpType: Word): Variant;
    function SetExpression1: Variant;
    procedure NextToken;
    function GetValue(Identifier: string; var Value: Variant;
      var Args: TJvInterpreterArgs): Boolean; virtual;
    function SetValue(Identifier: string; const Value: Variant;
      var Args: TJvInterpreterArgs): Boolean; virtual;
    function GetElement(const Variable: Variant; var Value: Variant;
      var Args: TJvInterpreterArgs): Boolean; virtual;
    function SetElement(var Variable: Variant; const Value: Variant;
      var Args: TJvInterpreterArgs): Boolean; virtual;
    procedure SourceChanged; dynamic;
    procedure SetAdapter(Adapter: TJvInterpreterAdapter);
    property Token: Variant read Token1;
    property TTyp: TTokenTyp read TTyp1;
    property TokenStr: string read GetTokenStr;
    property CurPos: Integer read GetCurPos write SetCurPos;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Run; dynamic;
    property Source: string read GetSource write SetSource;
    property VResult: Variant read FVResult;
    property OnGetValue: TJvInterpreterGetValue read FOnGetValue write FOnGetValue;
    property OnSetValue: TJvInterpreterSetValue read FOnSetValue write FOnSetValue;
    property Adapter: TJvInterpreterAdapter read FAdapter;
    property SharedAdapter: TJvInterpreterAdapter read FSharedAdapter;
    property BaseErrLine: Integer read FBaseErrLine write FBaseErrLine;
    property LastError: EJvInterpreterError read FLastError;
  end;
  TParserState = record
    CurPos: Integer;
    Token: Variant;
    TTyp: TTokenTyp;
    PrevTTyp: TTokenTyp;
    Backed: Boolean;
    AllowAssignment: Boolean;
  end;

  TJvInterpreterAddVarFunc = procedure(UnitName: string;
    Identifier, Typ: string; VTyp: Word; const Value: Variant; ADataType: IJvInterpreterDataType) of object;
  { Function executor }
  TJvInterpreterFunction = class(TJvInterpreterExpression)
  private
    FCurUnitName: string;
    FCurInstance: TObject;
    FBreak, FContinue, FExit: Boolean;
    FunStack: TList;
    FunContext: Pointer; { PFunContext }
    SS: TStrings;
    StateStack: array[0..cJvInterpreterStackMax] of TParserState;
    StateStackPtr: TStackPtr;
    FEventList: TList;
    function GetLocalVars: TJvInterpreterVarList;
    function GetFunStackCount: Integer;
    function GetDebugPointerToGlobalVars: TJvInterpreterVarList;
    function GetDebugPointerToFunStack: Pointer;
  protected
    procedure Init; override;
    procedure PushState;
    procedure PopState;
    procedure RemoveState;
    procedure InFunction1(FunDesc: TJvInterpreterFunDesc);
    procedure DoOnStatement; virtual;
    procedure Statement1;
    procedure SkipStatement1;
    procedure SkipToUntil1;
    procedure SkipIdentifier1;
    procedure SkipToEnd1;
    procedure FindToken1(TTyp1: TTokenTyp);
    procedure Var1(AddVarFunc: TJvInterpreterAddVarFunc);
    procedure Const1(AddVarFunc: TJvInterpreterAddVarFunc);
    procedure Identifier1;
    procedure Begin1;
    procedure If1;
    procedure While1;
    procedure Repeat1;
    procedure For1;
    procedure Case1;
    procedure Try1;
    procedure Raise1;
    function ParseDataType: IJvInterpreterDataType;
    function NewEvent(const UnitName: string; const FunName, EventType: string;
      Instance: TObject): TSimpleEvent;
    procedure InternalSetValue(const Identifier: string);
    function GetValue(Identifier: string; var Value: Variant;
      var Args: TJvInterpreterArgs): Boolean; override;
    function SetValue(Identifier: string; const Value: Variant;
      var Args: TJvInterpreterArgs): Boolean; override;
    property LocalVars: TJvInterpreterVarList read GetLocalVars;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Run; override;
    property CurUnitName: string read FCurUnitName;
    property CurInstance: TObject read FCurInstance write FCurInstance;
    property FunStackCount: Integer read GetFunStackCount;
    property DebugPointerToFunStack: Pointer read GetDebugPointerToFunStack;
    property DebugPointerToGlobalVars: TJvInterpreterVarList read GetDebugPointerToGlobalVars;
  end;

  TUnitSection =
    (usUnknown, usInterface, usImplementation, usInitialization, usFinalization);
  { Unit executor }