rm_jvinterpreter.pas.~1~

这是一个功能强大

    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Run; override;
  published
    property Pas: TStrings read GetPas 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;
    procedure CastTo(var Dest: TVarData; const Source: TVarData;
      const AVarType: TVarType); 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;
    FErrName1: string;
    FErrName2: string;
    FErrUnitName: string;
    FErrLine: Integer;
    FErrMessage: string;
  public
    constructor Create(const AErrCode: Integer; const AErrPos: Integer;
      const AErrName1, AErrName2: string);
    procedure Assign(E: Exception);
    procedure Clear;
    property ErrCode: Integer read FErrCode;
    property ErrPos: Integer read FErrPos;
    property ErrName1: string read FErrName1;
    property ErrName2: string read FErrName2;
    property ErrUnitName: string read FErrUnitName;
    property ErrLine: Integer read FErrLine;
    property ErrMessage: string read FErrMessage;
  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(const Identifier: string; Offset: Integer; Typ: Word): TJvInterpreterRecField;

{ raise error ieNotImplemented }
procedure NotImplemented(const Msg: 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(const 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(const TypeName: string): Word;

{ copy variant variable with all rm_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);

function GlobalJvInterpreterAdapter: TJvInterpreterAdapter;

const
  prArgsNoCheck = -1;
  noInstance = HINST(0);
  RFDNull: TJvInterpreterRecField = (Identifier: ''; Offset: 0; Typ: 0);

  varByConst = $8000;

  {rm_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 JvInterpreter_OLEAUTO}

  ieUserBase = $300;

  irExpression = 301;
  irIdentifier = 302;
  irDeclaration = 303;
  irEndOfFile = 304;
  irClass = 305;
  irIntegerConstant = 306;
  irIntegerValue = 307;
  irStringConstant = 308;
  irStatement = 309;

{$IFDEF UNITVERSIONING}
const
  UnitVersioning: TUnitVersionInfo = (
    RCSfile: '$RCSfile$';
    Revision: '$Revision: 10546 $';
    Date: '$Date: 2006-04-21 02:23:48 -0700 (Fri, 21 Apr 2006) $';
    LogPath: 'JVCL\run'
  );
{$ENDIF UNITVERSIONING}

implementation

uses
  TypInfo,
  {$IFDEF JvInterpreter_OLEAUTO}
  OleConst, ActiveX, ComObj,
  {$ENDIF JvInterpreter_OLEAUTO}
  rm_JvConsts, rm_JvInterpreterConst, rm_JvJVCLUtils, rm_JvJCLUtils, rm_JvResources, rm_JvTypes,
  rm_JvInterpreterFm; // required uses for class method support

var
  FieldGlobalJvInterpreterAdapter: TJvInterpreterAdapter = nil;

function GlobalJvInterpreterAdapter: TJvInterpreterAdapter;
begin
  if not Assigned(FieldGlobalJvInterpreterAdapter) then
    FieldGlobalJvInterpreterAdapter := TJvInterpreterAdapter.Create(nil);
  Result := FieldGlobalJvInterpreterAdapter;
end;

{ internal structures }

{$IFDEF VisualCLX}
type
  DWORD = Longint;
  PBool = PBoolean;
{$ENDIF VisualCLX}

{$IFDEF JvInterpreter_DEBUG}
var
  ObjCount: Integer = 0;
{$ENDIF JvInterpreter_DEBUG}

{$IFDEF COMPILER6_UP}

var
  GlobalVariantRecordInstance: TJvRecordVariantType = nil;
  GlobalVariantObjectInstance: TJvObjectVariantType = nil;
  GlobalVariantClassInstance: TJvClassVariantType = nil;
  GlobalVariantPointerInstance: TJvPointerVariantType = nil;
  GlobalVariantSetInstance: TJvSetVariantType = nil;
  GlobalVariantArrayInstance: TJvArrayVariantType = nil;

function VariantRecordInstance: TJvRecordVariantType;
begin
  if not Assigned(GlobalVariantRecordInstance) then
    GlobalVariantRecordInstance := TJvRecordVariantType.Create;
  Result := GlobalVariantRecordInstance;
end;

function VariantObjectInstance: TJvObjectVariantType;
begin
  if not Assigned(GlobalVariantObjectInstance) then
    GlobalVariantObjectInstance := TJvObjectVariantType.Create;
  Result := GlobalVariantObjectInstance;
end;

function VariantClassInstance: TJvClassVariantType;
begin
  if not Assigned(GlobalVariantClassInstance) then
    GlobalVariantClassInstance := TJvClassVariantType.Create;
  Result := GlobalVariantClassInstance;
end;

function VariantPointerInstance: TJvPointerVariantType;
begin
  if not Assigned(GlobalVariantPointerInstance) then
    GlobalVariantPointerInstance := TJvPointerVariantType.Create;
  Result := GlobalVariantPointerInstance;
end;

function VariantSetInstance: TJvSetVariantType;
begin
  if not Assigned(GlobalVariantSetInstance) then
    GlobalVariantSetInstance := TJvSetVariantType.Create;
  Result := GlobalVariantSetInstance;
end;

function VariantArrayInstance: TJvArrayVariantType;
begin
  if not Assigned(GlobalVariantArrayInstance) then
    GlobalVariantArrayInstance := TJvArrayVariantType.Create;
  Result := GlobalVariantArrayInstance;
end;

//=== { TJvSimpleVariantType } ===============================================

procedure TJvSimpleVariantType.CastTo(var Dest: TVarData;
  const Source: TVarData; const AVarType: TVarType);