rm_jvinterpreter.pas.~3~

这是一个功能强大

procedure TJvSimpleVariantType.CastTo(var Dest: TVarData;
  const Source: TVarData; const AVarType: TVarType);
begin
  //support only inherited classes
  Dest.VPointer := Source.VPointer;
  //inherited;
end;

procedure TJvSimpleVariantType.Clear(var V: TVarData);
begin
  SimplisticClear(V);
end;

procedure TJvSimpleVariantType.Copy(var Dest: TVarData;
  const Source: TVarData; const Indirect: Boolean);
begin
  SimplisticCopy(Dest, Source, Indirect);
end;

function varRecord: TVarType;
begin
  Result := VariantRecordInstance.VarType;
end;

function varObject: TVarType;
begin
  Result := VariantObjectInstance.VarType
end;

function varClass: TVarType;
begin
  Result := VariantClassInstance.VarType;
end;

function varPointer: TVarType;
begin
  Result := VariantPointerInstance.VarType;
end;

function varSet: TVarType;
begin
  Result := VariantSetInstance.VarType;
end;

function varArray: TVarType;
begin
  Result := VariantArrayInstance.VarType;
end;

{$ENDIF COMPILER6_UP}

//=== EJvInterpreterError ====================================================

function LoadStr2(const ResID: Integer): string;
var
  I: Integer;
begin
  for I := Low(JvInterpreterErrors) to High(JvInterpreterErrors) do
    if JvInterpreterErrors[I].ID = ResID then
    begin
      Result := JvInterpreterErrors[I].Description;
      Break;
    end;
end;

procedure JvInterpreterError(const AErrCode: Integer; const AErrPos: Integer);
begin
  raise EJvInterpreterError.Create(AErrCode, AErrPos, '', '');
end;

procedure JvInterpreterErrorN(const AErrCode: Integer; const AErrPos: Integer;
  const AErrName: string);
begin
  raise EJvInterpreterError.Create(AErrCode, AErrPos, AErrName, '');
end;

procedure JvInterpreterErrorN2(const AErrCode: Integer; const AErrPos: Integer;
  const AErrName1, AErrName2: string);
begin
  raise EJvInterpreterError.Create(AErrCode, AErrPos, AErrName1, AErrName2);
end;

constructor EJvInterpreterError.Create(const AErrCode: Integer;
  const AErrPos: Integer; const AErrName1, AErrName2: string);
begin
  inherited Create('');
  FErrCode := AErrCode;
  FErrPos := AErrPos;
  FErrName1 := AErrName1;
  FErrName2 := AErrName2;
  { function LoadStr don't work sometimes :-( }
  Message := Format(LoadStr2(ErrCode), [ErrName1, ErrName2]);
  FErrMessage := Message;
end;

procedure EJvInterpreterError.Assign(E: Exception);
begin
  Message := E.Message;
  if E is EJvInterpreterError then
  begin
    FErrCode := (E as EJvInterpreterError).ErrCode;
    FErrPos := (E as EJvInterpreterError).ErrPos;
    FErrName1 := (E as EJvInterpreterError).ErrName1;
    FErrName2 := (E as EJvInterpreterError).ErrName2;
    FErrMessage := (E as EJvInterpreterError).ErrMessage;
  end;
end;

procedure EJvInterpreterError.Clear;
begin
  FExceptionPos := False;
  FErrName1 := '';
  FErrName2 := '';
  FErrPos := -1;
  FErrLine := -1;
  FErrUnitName := '';
end;

function V2O(const V: Variant): TObject;
begin
  Result := TVarData(V).VPointer;
end;

function O2V(O: TObject): Variant;
begin
  TVarData(Result).VType := varObject;
  TVarData(Result).VPointer := O;
end;

function V2C(const V: Variant): TClass;
begin
  Result := TVarData(V).VPointer;
end;

function C2V(C: TClass): Variant;
begin
  TVarData(Result).VType := varClass;
  TVarData(Result).VPointer := C;
end;

function V2P(const V: Variant): Pointer;
begin
  Result := TVarData(V).VPointer;
end;

function P2V(P: Pointer): Variant;
begin
  TVarData(Result).VType := varPointer;
  TVarData(Result).VPointer := P;
end;

function R2V(const ARecordType: string; ARec: Pointer): Variant;
begin
  TVarData(Result).VPointer := TJvInterpreterRecHolder.Create(ARecordType, ARec);
  TVarData(Result).VType := varRecord;
end;

function V2R(const V: Variant): Pointer;
begin
  if (TVarData(V).VType <> varRecord) or
    not (TObject(TVarData(V).VPointer) is TJvInterpreterRecHolder) then
    JvInterpreterError(ieROCRequired, -1);
  Result := TJvInterpreterRecHolder(TVarData(V).VPointer).Rec;
end;

function P2R(const P: Pointer): Pointer;
begin
  if not (TObject(P) is TJvInterpreterRecHolder) then
    JvInterpreterError(ieROCRequired, -1);
  Result := TJvInterpreterRecHolder(P).Rec;
end;

function S2V(const I: Integer): Variant;
begin
  Result := I;
  TVarData(Result).VType := varSet;
end;

function V2S(V: Variant): Integer;
var
  I: Integer;
begin
  if (TVarData(V).VType and System.varArray) = 0 then
    Result := TVarData(V).VInteger
  else
  begin
    { rm_JvInterpreter thinks about all function parameters, started
      with '[' symbol that they are open arrays;
      but it may be set constant, so we must convert it now }
    Result := 0;
    for I := VarArrayLowBound(V, 1) to VarArrayHighBound(V, 1) do
      Result := Result or 1 shl Integer(V[I]);
  end;
end;

function RFD(const Identifier: string; Offset: Integer; Typ: Word): TJvInterpreterRecField;
begin
  Result.Identifier := Identifier;
  Result.Offset := Offset;
  Result.Typ := Typ;
end;

procedure NotImplemented(const Msg: string);
begin
  JvInterpreterErrorN(ieInternal, -1, Msg + RsENotImplemented);
end;

//RWare: added check for "char", otherwise function with ref variable
//of type char causes AV, like KeyPress event handler

function Typ2Size(ATyp: Word): Integer;
begin
  Result := 0;
  case ATyp of
    varInteger:
      Result := SizeOf(Integer);
    varDouble:
      Result := SizeOf(Double);
    varByte:
      Result := SizeOf(Byte);
    varSmallint:
      Result := SizeOf(Smallint);
    varDate:
      Result := SizeOf(Double);
    varEmpty, varVariant, varOleStr, varDispatch, varUnknown:
      Result := SizeOf(TVarData);
  else
    if ATyp = varObject then
      Result := SizeOf(Integer);
  end;
end;

{$IFNDEF COMPILER6_UP}
function VarArrayOffset(const A: Variant; const Indices: array of Integer): Integer;
var
  DimValue, h, l, Dim: Integer;
begin
  Result := 0;
  DimValue := 1;
  for Dim := 1 to VarArrayDimCount(A) do
  begin
    l := VarArrayLowBound(A, Dim);
    h := VarArrayHighBound(A, Dim);
    if Dim = 1 then
    begin
      Result := Indices[Dim - 1] - l;
      DimValue := h - l + 1;
    end
    else
    begin
      Result := Result + (Indices[Dim - 1] - l) * DimValue;
      DimValue:=(h - l + 1) * DimValue;
    end;
  end;
end;

function VarArrayGet(const A: Variant; Indices: array of Integer): Variant;
var
  P, P1: Pointer;
  LVarType: Cardinal;
begin
  P := VarArrayLock(A);
  try
    LVarType := VarType(A) and varTypeMask;
    P1 := Pointer(Integer(P) + Typ2Size(LVarType) * VarArrayOffset(A, Indices));
    if LVarType = varVariant then
      Result := PVariant(P1)^
    else
    begin
      TVarData(Result).VType := LVarType;
      Move(P1^, TVarData(Result).VInteger, Typ2Size(LVarType));
    end;
  finally
    VarArrayUnlock(A);
  end;
end;

procedure VarArrayPut(const A: Variant; const Value: Variant; const Indices: array of Integer);
var
  P, P1:pointer;
  LVarType: Cardinal;
  Temp: TVarData;
begin
  P := VarArrayLock(A);
  try
    LVarType := VarType(A) and varTypeMask;
    P1 := Pointer(Integer(P) + Typ2Size(LVarType) * VarArrayOffset(A, Indices));

    if LVarType = varVariant then
      PVariant(P1)^ := Value
    else
    begin
      VarCast(Variant(Temp), Value, LVarType);
      case LVarType of
        varOleStr, varDispatch, varUnknown:
          P := Temp.VPointer;
      else
        P := @Temp.VPointer;
      end;
      Move(P^, P1^, Typ2Size(LVarType));
    end;
  finally
    VarArrayUnlock(A);
  end;
end;
{$ENDIF}

function TypeName2VarTyp(const TypeName: string): Word;
begin
  // (rom) reimplemented for speed
  // (rom) LongBool added (untested)
  Result := varEmpty;
  if TypeName <> '' then
  begin
    case TypeName[1] of
      'A', 'a':
        if Cmp(TypeName, 'AnsiString') then
          Result := varString;
      'B', 'b':
        if Cmp(TypeName, 'boolean') or Cmp(TypeName, 'bool') then
          Result := varBoolean
        else
        if Cmp(TypeName, 'byte') then
          Result := varByte;
      'C', 'c':
        if Cmp(TypeName, 'char') then {+RWare}
          Result := varString;
      'D', 'd':
        if Cmp(TypeName, 'dword') then
          Result := varInteger
        else
        if Cmp(TypeName, 'double') then
          Result := varDouble;
      'I', 'i':
        if Cmp(TypeName, 'integer') then
          Result := varInteger;
      'L', 'l':
        if Cmp(TypeName, 'longint') then