rm_jvinterpreter.pas

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

  TJvInterpreterUnit = class(TJvInterpreterFunction)
  private
    FClearUnits: Boolean;
    FEventHandlerList: TList;
    FOnGetUnitSource: TJvInterpreterGetUnitSource;
    FUnitSection: TUnitSection;
  protected
    procedure Init; override;
    procedure ReadFunHeader(FunDesc: TJvInterpreterFunDesc);
    procedure Uses1(var UsesList: string);
    procedure ReadUnit(const UnitName: string);
    procedure Function1;
    procedure Unit1;
    procedure Type1;
    procedure Class1(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;
    function GetUnitSource(UnitName: string; var Source: string): Boolean; dynamic;
    procedure ExecFunction(Fun: TJvInterpreterFunDesc);
    procedure SourceChanged; override;
    procedure Record1(const Identifier: string);
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Run; override;
    procedure DeclareExternalFunction(const Declaration: string);
    procedure Compile;
    function CallFunction(const FunName: string; Args: TJvInterpreterArgs;
      Params: array of Variant): Variant; override;
    function CallFunctionEx(Instance: TObject; const UnitName: string;
      const FunName: string; Args: TJvInterpreterArgs;
      Params: array of Variant): Variant; override;
    function FunctionExists(const UnitName: string;
      const FunName: string): Boolean;
    property OnGetUnitSource: TJvInterpreterGetUnitSource read FOnGetUnitSource
      write FOnGetUnitSource;
    property UnitSection: TUnitSection read FUnitSection;
  end;

  { main JvInterpreter component }
  TJvInterpreterProgram = class(TJvInterpreterUnit)
  private
    FPas: TStrings;
    FOnStatement: TNotifyEvent;
    procedure SetPas(Value: TStrings);
  protected
    procedure DoOnStatement; override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Run; override;
  published
    property Pas: TStrings read FPas write SetPas;
    property OnGetValue;
    property OnSetValue;
    property OnGetUnitSource;
    property OnStatement: TNotifyEvent read FOnStatement write FOnStatement;
  end;

{$IFDEF COMPILER6_UP}
  TJvSimpleVariantType = class(TCustomVariantType)
  public
    procedure Clear(var V: TVarData); override;
    procedure Copy(var Dest: TVarData; const Source: TVarData;
      const Indirect: Boolean); override;
  end;

  TJvRecordVariantType = class(TJvSimpleVariantType);
  TJvObjectVariantType = class(TJvSimpleVariantType);
  TJvClassVariantType = class(TJvSimpleVariantType);
  TJvPointerVariantType = class(TJvSimpleVariantType);
  TJvSetVariantType = class(TJvSimpleVariantType);
  TJvArrayVariantType = class(TJvSimpleVariantType);
{$ENDIF COMPILER6_UP}
  EJvInterpreterError = class(Exception)
  private
    FExceptionPos: Boolean;
    FErrCode: Integer;
    FErrPos: Integer;
    FErrName: string;
    FErrName2: string;
    FErrUnitName: string;
    FErrLine: Integer;
    FMessage1: string;
  public
    constructor Create(const AErrCode: Integer; const AErrPos: Integer;
      const AErrName, AErrName2: string);
    procedure Assign(E: Exception);
    procedure Clear;
    property ErrCode: Integer read FErrCode;
    property ErrPos: Integer read FErrPos;
    property ErrName: string read FErrName;
    property ErrName2: string read FErrName2;
    property ErrUnitName: string read FErrUnitName;
    property ErrLine: Integer read FErrLine;
    property Message1: string read FMessage1;
  end;

  TJvInterpreterRecFields = array[0..cJvInterpreterMaxRecFields] of TJvInterpreterRecField;
  TJvInterpreterRecord = class(TJvInterpreterIdentifier)
  private
    RecordSize: Integer; { SizeOf(Rec^) }
    FieldCount: Integer;
    Fields: TJvInterpreterRecFields;
    CreateFunc: TJvInterpreterAdapterNewRecord;
    DestroyFunc: TJvInterpreterAdapterDisposeRecord;
    CopyFunc: TJvInterpreterAdapterCopyRecord;
    procedure AddField(UnitName, Identifier, Typ: string; VTyp: Word;
      const Value: Variant; DataType: IJvInterpreterDataType);
    procedure NewRecord(var Value: Variant);
  end;

  TJvInterpreterArrayValues = array[0..JvInterpreter_MAX_ARRAY_DIMENSION - 1] of Integer;
  TJvInterpreterArrayDataType = class(TInterfacedObject, IJvInterpreterDataType)
  private
    FArrayBegin, FArrayEnd: TJvInterpreterArrayValues;
    FDimension: Integer;
    FArrayType: Integer;
    FDT: IJvInterpreterDataType;
  public
    constructor Create(AArrayBegin, AArrayEnd: TJvInterpreterArrayValues;
      ADimension: Integer; AArrayType: Integer; ADT: IJvInterpreterDataType);
    procedure Init(var V: Variant);
    function GetTyp: Word;
  end;

 {Error raising routines}
procedure JvInterpreterError(const AErrCode: Integer; const AErrPos: Integer);
procedure JvInterpreterErrorN(const AErrCode: Integer; const AErrPos: Integer;
  const AErrName: string);
procedure JvInterpreterErrorN2(const AErrCode: Integer; const AErrPos: Integer;
  const AErrName1, AErrName2: string);
{Utilities functions}
//function LoadStr2(const ResID: Integer): string;
{ RFD - RecordFieldDefinition - return record needed for TJvInterpreterAdapter.AddRec
  Fields parameter }
function RFD(Identifier: string; Offset: Integer; Typ: Word): TJvInterpreterRecField;
{ raise error ieNotImplemented }
procedure NotImplemented(Message: string);
{ clear list of TObject }
procedure ClearList(List: TList);

{ additional variant types - TVarData.VType }
{$IFDEF COMPILER6_UP}
function varRecord: TVarType;
function varObject: TVarType;
function varClass: TVarType;
function varPointer: TVarType;
function varSet: TVarType;
function varArray: TVarType;
{$ELSE}
const
  varRecord = $0015;
  varObject = $0010;
  varClass = $0011;
  varPointer = $0012;
  varSet = $0013;
  varArray = $0014;
{$ENDIF COMPILER6_UP}

{ V2O - converts variant to object }
function V2O(const V: Variant): TObject;
{ O2V - converts object to variant }
function O2V(O: TObject): Variant;
{ V2C - converts variant to class }
function V2C(const V: Variant): TClass;
{ O2V - converts class to variant }
function C2V(C: TClass): Variant;
{ V2P - converts variant to pointer }
function V2P(const V: Variant): Pointer;
{ P2V - converts pointer to variant }
function P2V(P: Pointer): Variant;
{ R2V - create record holder and put it into variant }
function R2V(ARecordType: string; ARec: Pointer): Variant;
{ V2R - returns pointer to record from variant, containing record holder }
function V2R(const V: Variant): Pointer;
{ P2R - returns pointer to record from record holder, typically Args.Obj }
function P2R(const P: Pointer): Pointer;
{ S2V - converts Integer to set and put it into variant }
function S2V(const I: Integer): Variant;
{ V2S - give a set from variant and converts it to Integer }
function V2S(V: Variant): Integer;
procedure V2OA(V: Variant; var OA: TOpenArray; var OAValues: TValueArray;
  var Size: Integer);
function TypeName2VarTyp(TypeName: string): Word;
{ copy variant variable with all JvInterpreter variant extension }
procedure JvInterpreterVarCopy(var Dest: Variant; const Source: Variant);
{ copy variant variable for assignment }
procedure JvInterpreterVarAssignment(var Dest: Variant; const Source: Variant);
function JvInterpreterVarAsType(const V: Variant; const VarType: Integer): Variant;
{ properly free var variable and set it content to empty }
procedure JvInterpreterVarFree(var V: Variant);
{ compare strings }
function Cmp(const S1, S2: string): Boolean;
{ For dynamic array support}
procedure JvInterpreterArraySetLength(AArray: Variant; ASize: integer);
function JvInterpreterArrayLength(const AArray: Variant): integer;
function JvInterpreterArrayLow(const AArray: Variant): integer;
function JvInterpreterArrayHigh(const AArray: Variant): integer;
procedure JvInterpreterArrayElementDelete(AArray: Variant; AElement: integer);
procedure JvInterpreterArrayElementInsert(AArray: Variant; AElement: integer; Value: Variant);

var
  GlobalJvInterpreterAdapter: TJvInterpreterAdapter = nil;

const
  prArgsNoCheck = -1;
  noInstance = HINST(0);
  RFDNull: TJvInterpreterRecField = (Identifier: ''; Offset: 0; Typ: 0);
  {JvInterpreter error codes}
  ieOk = 0; { Okay - no errors }
  ieUnknown = 1;
  ieInternal = 2;
  ieUserBreak = 3; { internal }
  ieRaise = 4; { internal }
  ieErrorPos = 5;
  ieExternal = 6; { non-interpreter error }
  ieAccessDenied = 7;
  ieExpressionStackOverflow = 8;
  { register-time errors }
  ieRegisterBase = 30;
  ieRecordNotDefined = ieRegisterBase + 1;
  { run-time errors }
  ieRuntimeBase = 50;
  ieStackOverFlow = ieRuntimeBase + 2;
  ieTypeMistmatch = ieRuntimeBase + 3;
  ieIntegerOverflow = ieRuntimeBase + 4;
  ieMainUndefined = ieRuntimeBase + 5;
  ieUnitNotFound = ieRuntimeBase + 6;
  ieEventNotRegistered = ieRuntimeBase + 7;
  ieDfmNotFound = ieRuntimeBase + 8;
  { syntax errors (now run-timed) }
  ieSyntaxBase = 100;
  ieBadRemark = ieSyntaxBase + 1; { Bad remark - detected by parser }
  ieIdentifierExpected = ieSyntaxBase + 2;
  ieExpected = ieSyntaxBase + 3;
  ieUnknownIdentifier = ieSyntaxBase + 4;
  ieBooleanRequired = ieSyntaxBase + 5;
  ieClassRequired = ieSyntaxBase + 6;
  ieNotAllowedBeforeElse = ieSyntaxBase + 7;
  ieIntegerRequired = ieSyntaxBase + 8;
  ieROCRequired = ieSyntaxBase + 9;
  ieMissingOperator = ieSyntaxBase + 10;
  ieIdentifierRedeclared = ieSyntaxBase + 11;
  { array indexes }
  ieArrayBase = 170;
  ieArrayIndexOutOfBounds = ieArrayBase + 1;
  ieArrayTooManyParams = ieArrayBase + 2;
  ieArrayNotEnoughParams = ieArrayBase + 3;
  ieArrayBadDimension = ieArrayBase + 4;
  ieArrayBadRange = ieArrayBase + 5;
  ieArrayRequired = ieArrayBase + 6;
  { function call errors (now run-timed) }
  ieFunctionBase = 180;
  ieTooManyParams = ieFunctionBase + 1;
  ieNotEnoughParams = ieFunctionBase + 2;
  ieIncompatibleTypes = ieFunctionBase + 3;
  ieDllErrorLoadLibrary = ieFunctionBase + 4;
  ieDllInvalidArgument = ieFunctionBase + 5;
  ieDllInvalidResult = ieFunctionBase + 6;
  ieDllFunctionNotFound = ieFunctionBase + 7;
  ieDirectInvalidArgument = ieFunctionBase + 8;
  ieDirectInvalidResult = ieFunctionBase + 9;
  ieDirectInvalidConvention = ieFunctionBase + 10;
{$IFDEF JvInterpreter_OLEAUTO}
  ieOleAuto = ieFunctionBase + 21;
{$ENDIF}
  ieUserBase = $300;
  irExpression = 301;
  irIdentifier = 302;
  irDeclaration = 303;
  irEndOfFile = 304;
  irClass = 305;

implementation

uses
  TypInfo,
{$IFNDEF COMPILER3_UP}
  Ole2, { IUnknown in Delphi 2 }
{$ENDIF}
{$IFDEF JvInterpreter_OLEAUTO}
  OleConst,
{$IFDEF COMPILER3_UP}
  ActiveX, ComObj,
{$ELSE}
  OleAuto,
{$ENDIF COMPILER3_UP}
{$ENDIF JvInterpreter_OLEAUTO}
  rm_JvInterpreterConst, rm_JvUtils, rm_JvStrUtil;
{$R rm_JvInterpreter.res} { error messages }
{ internal structures }

type
  { Adapter classes - translates data from JvInterpreter calls to Delphi functions }
  TJvInterpreterSrcUnit = class(TJvInterpreterIdentifier)
  private
    Source: string;
    UsesList: TNameArray;
  end;

  TParamCount = -1..cJvInterpreterMaxArgs;
  TJvInterpreterMethod = class(TJvInterpreterIdentifier)
  private
    FClassType: TClass;
    ParamCount: TParamCount;
    ParamTypes: TTypeArray; { varInteger, varString, .. }
    ResTyp: Word; { varInteger, varString, .. }
    Func: Pointer; { TJvInterpreterAdapterGetValue or TJvInterpreterAdapterSetValue }
  end;

  TJvInterpreterIntfMethod = class(TJvInterpreterIdentifier)
  private
    IID: TGUID;
    ParamCount: TParamCount;
    ParamTypes: TTypeArray; { varInteger, varString, .. }
    ResTyp: Word; { varInteger, varString, .. }
    Func: Pointer; { TJvInterpreterAdapterGetValue or TJvInterpreterAdapterSetValue }
  end;

  TJvInterpreterDMethod = class(TJvInterpreterMethod)
  private
    ResTyp: Word;
    CallConvention: TCallConvention;
  end;

  TJvInterpreterClass = class(TJvInterpreterIdentifier)
  private
    FClassType: TClass;
  end;

  TJvInterpreterConst = class(TJvInterpreterIdentifier)
  private
    Value: Variant;
  end;

  TJvInterpreterRecMethod = class(TJvInterpreterIdentifier)
  private
    JvInterpreterRecord: TJvInterpreterRecord;
    ParamCount: TParamCount;
    ParamTypes: TTypeArray; { varInteger, varString and so one .. }
    ResTyp: Word; { varInteger, varString, .. }
    Func: Pointer; { TJvInterpreterAdapterGetValue or TJvInterpreterAdapterSetValue }
  end;

  TJvInterpreterRecHolder = class(TJvInterpreterIdentifier)
  private
    FRecordType: string;
    JvInterpreterRecord: TJvInterpreterRecord;
    Rec: Pointer; { data }
  public
    constructor Create(ARecordType: string; ARec: Pointer);
    destructor Destroy; override;